src/tool/Creation_Maillage/cmrdqu.F

   1       subroutine cmrdqu ( coonoe, hetnoe, arenoe,
   2      >                    somare, hetare, filare, merare,
   3      >                    arequa, hetqua, filqua, perqua,
   4      >                    nivqua, ninqua, decfac,
   5      >                    famnoe, famare, famqua,
   6      >                    indnoe, indare, indqua,
   7      >                    cfaqua,
   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    Creation du Maillage - Raffinement - Decoupage des QUadrangles
  30 c    -           -          -             -             --
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . coonoe . es  .nouvno*3. coordonnees des noeuds                     .
  36 c . hetnoe . es  . nouvno . historique de l'etat des noeuds            .
  37 c . arenoe . es  . nouvno . arete liee a un nouveau noeud              .
  38 c . somare . es  .2*nouvar. numeros des extremites d'arete             .
  39 c . hetare . es  . nouvar . historique de l'etat des aretes            .
  40 c . filare . es  . nouvar . premiere fille des aretes                  .
  41 c . merare . es  . nouvar . mere des aretes                            .
  42 c . arequa . es  .nouvqu*4. numeros des 4 aretes des quadrangles       .
  43 c . hetqua . es  . nouvqu . historique de l'etat des quadrangles       .
  44 c . filqua . es  . nouvqu . premier fils des quadrangles               .
  45 c . perqua . es  . nouvqu . pere des quadrangles                       .
  46 c . nivqua . es  . nouvqu . niveau des quadrangles                     .
  47 c . ninqua . es  . nouvqu . noeud interne au quadrangle                .
  48 c . decfac . es  . -nouvqu. decision sur les faces (quad. + tri.)      .
  49 c .        .     . :nouvqu.                                            .
  50 c . famnoe .     . nouvno . famille des noeuds                         .
  51 c . famare .     . nouvar . famille des aretes                         .
  52 c . famqua . es  . nouvqu . famille des quadrangles                    .
  53 c . indnoe . es  . 1      . indice du derniere noeud cree              .
  54 c . indare . es  . 1      . indice de la derniere arete creee          .
  55 c . indqua . es  . 1      . indice du dernier quadrangle cree          .
  56 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
  57 c .        .     . nbfqua .   1 : famille MED                          .
  58 c .        .     .        .   2 : type de quadrangle                   .
  59 c .        .     .        .   3 : numero de surface de frontiere       .
  60 c .        .     .        .   4 : famille des aretes internes apres raf.
  61 c .        .     .        .   5 : famille des triangles de conformite  .
  62 c .        .     .        .   6 : famille de sf active/inactive        .
  63 c .        .     .        . + l : appartenance a l'equivalence l       .
  64 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  65 c . langue . e   .    1   . langue des messages                        .
  66 c .        .     .        . 1 : francais, 2 : anglais                  .
  67 c . codret . es  .    1   . code de retour des modules                 .
  68 c .        .     .        . 0 : pas de probleme                        .
  69 c ______________________________________________________________________
  70 c
  71 c====
  72 c 0. declarations et dimensionnement
  73 c====
  74 c
  75 c 0.1. ==> generalites
  76 c
  77       implicit none
  78       save
  79 c
  80       character*6 nompro
  81       parameter ( nompro = 'CMRDQU' )
  82 c
  83 #include "nblang.h"
  84 #include "fractc.h"
  85 #include "cofatq.h"
  86 c
  87 c 0.2. ==> communs
  88 c
  89 #include "envex1.h"
  90 #include "envca1.h"
  91 #include "nombqu.h"
  92 #include "nouvnb.h"
  93 #include "dicfen.h"
  94 #include "nbfami.h"
  95 c
  96 c 0.3. ==> arguments
  97 c
  98       double precision coonoe(nouvno,sdim)
  99 c
 100       integer hetnoe(nouvno), arenoe(nouvno)
 101 c
 102       integer decfac(-nouvqu:nouvtr)
 103       integer somare(2,nouvar), hetare(nouvar), filare(nouvar)
 104       integer merare(nouvar)
 105       integer arequa(nouvqu,4), hetqua(nouvqu)
 106       integer filqua(nouvqu), perqua(nouvqu), nivqua(nouvqu)
 107       integer ninqua(nouvqu)
 108       integer famnoe(nouvno), famare(nouvar), famqua(nouvqu)
 109       integer indnoe, indare, indqua
 110       integer cfaqua(nctfqu,nbfqua)
 111 c
 112       integer ulsort, langue, codret
 113 c
 114 c 0.4. ==> variables locales
 115 c
 116       integer iaux, jaux
 117       integer a1, a2, a3, a4
 118       integer sa1a2, sa2a3, sa3a4, sa4a1
 119       integer n0, n1, n2, n3, n4
 120       integer a1f1, a1f2, a2f1, a2f2, a3f1, a3f2, a4f1, a4f2
 121       integer an1n0, an2n0, an3n0, an4n0
 122       integer nf1, nf2, nf3, nf4
 123       integer etat, niv, lepere
 124       integer lequad
 125 c
 126       logical noinma
 127 c
 128       integer nbmess
 129       parameter ( nbmess = 10 )
 130       character*80 texte(nblang,nbmess)
 131 c
 132 c 0.5. ==> initialisations
 133 c ______________________________________________________________________
 134 c
 135 c====
 136 c 1. preliminaires
 137 c====
 138 c
 139 c 1.1. ==> messages
 140 c
 141 #include "impr01.h"
 142 c
 143 #ifdef _DEBUG_HOMARD_
 144       write (ulsort,texte(langue,1)) 'Entree', nompro
 145       call dmflsh (iaux)
 146 #endif
 147 c
 148       texte(1,4) = '(''Decoupage du quadrangle'',i10)'
 149       texte(1,5) = '(''.. Noeud milieu'',i10,'', coor :'',3g15.7)'
 150       texte(1,6) = '(''.. Arete interne'',i10,'', de'',i10,'' a'',i10)'
 151       texte(1,7) = '(''.. Quad fils'',i10,'', aretes :'',4i10)'
 152 c
 153       texte(2,4) = '(''Splitting of quadrangle #'',i10)'
 154       texte(2,5) = '(''.. Central node'',i10,'', coor:'',3g15.7)'
 155       texte(2,6) =
 156      > '(''.. Internal edge'',i10,'', from'',i10,'' to'',i10)'
 157       texte(2,7) = '(''.. Quad son'',i10,'', edges:'',4i10)'
 158 c
 159 #include "impr03.h"
 160 c
 161 #ifdef _DEBUG_HOMARD_
 162         write (ulsort,*) 'entree de ',nompro
 163         do 1101 , iaux = 1 , min(nouvar,1)
 164           write (ulsort,90001) 'arete', iaux,
 165      >    somare(1,iaux), somare(2,iaux)
 166  1101   continue
 167         do 1105 , lequad = 1 , min(nouvqu,1)
 168           write (ulsort,90001) 'quadrangle', lequad,
 169      >    arequa(lequad,1), arequa(lequad,2),
 170      >    arequa(lequad,3), arequa(lequad,4)
 171  1105   continue
 172              lequad = 1
 173           write (ulsort,90001) 'fils du quadrangle', lequad,
 174      >    filqua(lequad)
 175       call dmflsh (iaux)
 176 #endif
 177 c
 178       if ( mod(mailet,3).eq.0 ) then
 179         noinma = .true.
 180       else
 181         noinma = .false.
 182       endif
 183 c
 184 c====
 185 c 1. decoupage en 4 des quadrangles de decision 4
 186 c====
 187 c
 188 c   Quadrangle pere :
 189 c     ak = numero de la k-eme arete du quadrangle pere
 190 c     sajak = numero du noeud commun aux aretes aj et ak
 191 c
 192 c       sa4a1                       a4                        sa3a4
 193 c           ._________________________________________________.
 194 c           .                                                 .
 195 c           .                                                 .
 196 c           .                                                 .
 197 c           .                                                 .
 198 c           .                                                 .
 199 c           .                                                 .
 200 c        a1 .                                                 . a3
 201 c           .                                                 .
 202 c           .                                                 .
 203 c           .                                                 .
 204 c           .                                                 .
 205 c           .                                                 .
 206 c           .                                                 .
 207 c           ._________________________________________________.
 208 c       sa1a2                       a2                        sa2a3
 209 c
 210 c   Remarque : on appelle ici le sens standard celui correspondant
 211 c              a l'enchainement (a1,a2,a3,a4)
 212 c
 213 c   Quadrangles fils :
 214 c     n0 = numero du noeud barycentre des 4 sommets du quadrangle pere
 215 c     nk = numero du noeud milieu de la k-eme arete du quadrangle pere
 216 c     akf1/2 = numero des filles de la k-eme arete du quadrangle pere
 217 c              akf1 : la premiere dans le sens standard
 218 c              akf2 : la seconde dans le sens standard
 219 c     nfk = numero du k-eme quadrangle fils : celui qui contient la
 220 c           premiere (au sens standard) des filles de l'arete ak
 221 c     ankn0 = numero de l'arete qui va de nk a n0. (Par construction,
 222 c             n0>nk). Elle est commune aux filles nfk et nf(k+1).
 223 c
 224 c       sa4a1          a4f2        a4/n4        a4f1          sa3a4
 225 c           .________________________.________________________.
 226 c           .                        .                        .
 227 c           .                        .                        .
 228 c           .                        .an4n0                   .
 229 c      a1f1 .          nf1           .          nf4           . a3f2
 230 c           .                        .                        .
 231 c           .                        .                        .
 232 c     a1/n1 .________________________.________________________. a3/n3
 233 c           .         an1n0          .n0       an3n0          .
 234 c           .                        .                        .
 235 c           .                        .an2n0                   .
 236 c      a1f2 .          nf2           .          nf3           . a3f1
 237 c           .                        .                        .
 238 c           .                        .                        .
 239 c           .________________________.________________________.
 240 c       sa1a2         a2f1         a2/n2        a2f2          sa2a3
 241 c
 242 c
 243       do 100 , lequad = 1 , nbqupe
 244 c
 245 cgn      write (ulsort,90002)'decision', decfac(-lequad)
 246         if ( decfac(-lequad) .eq. 4 ) then
 247 #ifdef _DEBUG_HOMARD_
 248       write (ulsort,texte(langue,4)) lequad
 249 #endif
 250 c
 251 c 1.1. ==> determination des numeros d'aretes
 252 c
 253           a1 = arequa(lequad,1)
 254           a2 = arequa(lequad,2)
 255           a3 = arequa(lequad,3)
 256           a4 = arequa(lequad,4)
 257 cgn      write (ulsort,90002)'.. indqua',indqua
 258 cgn      write (ulsort,90002)'.. indare',indare
 259 cgn      write (ulsort,90002)'.. aretes     ',a1, a2, a3, a4
 260 cgn      write (ulsort,90002)'.. de filles  ',filare(a1), filare(a2),
 261 cgn     >                                filare(a3), filare(a4)
 262 c
 263 c 1.2. ==> determination des 4 sommets
 264 c
 265           call utsoqu ( somare, a1, a2, a3, a4,
 266      >                  sa1a2, sa2a3, sa3a4, sa4a1 )
 267 cgn      write (ulsort,90002)'.. sommets',sa1a2, sa2a3, sa3a4, sa4a1
 268 c
 269 c 1.3. ==> determination des 8 demi-aretes filles des precedentes
 270 c
 271           call utafqu ( somare, filare, a1, a2, a3, a4,
 272      >                  a1f1, a1f2,
 273      >                  a2f1, a2f2,
 274      >                  a3f1, a3f2,
 275      >                  a4f1, a4f2 )
 276 cgn      write (ulsort,90002)'.. a1f1/2',a1f1,a1f2
 277 cgn      write (ulsort,90002)'.. a2f1/2',a2f1,a2f2
 278 cgn      write (ulsort,90002)'.. a3f1/2',a3f1,a3f2
 279 cgn      write (ulsort,90002)'.. a4f1/2',a4f1,a4f2
 280 c
 281 c 1.4. ==> determination des noeuds milieux
 282 c
 283           n1 = somare(2,a1f1)
 284           n2 = somare(2,a2f1)
 285           n3 = somare(2,a3f1)
 286           n4 = somare(2,a4f1)
 287 cgn      write (ulsort,90002)'.. nk',n1, n2, n3, n4
 288 c
 289 c 1.5. ==> le sommet central
 290 c          . on le cree au barycentre du quadrangle s'il n'existe pas
 291 c          . on le recupere sinon
 292 c
 293           if ( noinma ) then
 294 c
 295             n0 = ninqua(lequad)
 296 c
 297           else
 298 c
 299             n0 = indnoe + 1
 300             arenoe(n0) = 0
 301             coonoe(n0,1) = ( coonoe(sa4a1,1) +
 302      >                       coonoe(sa1a2,1) +
 303      >                       coonoe(sa2a3,1) +
 304      >                       coonoe(sa3a4,1) ) * unsqu
 305             coonoe(n0,2) = ( coonoe(sa4a1,2) +
 306      >                       coonoe(sa1a2,2) +
 307      >                       coonoe(sa2a3,2) +
 308      >                       coonoe(sa3a4,2) ) * unsqu
 309             if ( sdim.eq.3 ) then
 310               coonoe(n0,3) = ( coonoe(sa4a1,3) +
 311      >                         coonoe(sa1a2,3) +
 312      >                         coonoe(sa2a3,3) +
 313      >                         coonoe(sa3a4,3) ) * unsqu
 314             endif
 315             famnoe(n0) = 1
 316             hetnoe(n0) = 51
 317             indnoe = n0
 318 c
 319           endif
 320 #ifdef _DEBUG_HOMARD_
 321           if ( sdim.eq.3 ) then
 322              write (ulsort,texte(langue,5)) n0,
 323      >                            coonoe(n0,1),coonoe(n0,2),coonoe(n0,3)
 324           else
 325              write (ulsort,texte(langue,5)) n0,
 326      >                            coonoe(n0,1),coonoe(n0,2)
 327           endif
 328 #endif
 329 cgn      write (ulsort,90002)'.. n0',n0
 330 c
 331 c 1.6. ==> creation des aretes internes
 332 c 1.6.1. ==> leurs numeros
 333 c
 334           an1n0 = indare + 1
 335           an2n0 = indare + 2
 336           an3n0 = indare + 3
 337           an4n0 = indare + 4
 338           indare = an4n0
 339 cgn      write (ulsort,90002)'.. ankn0',an1n0,an2n0,an3n0,an4n0
 340 c
 341 c 1.6.2. ==> les numeros de leurs sommets avec la convention ad'hoc
 342 c
 343           somare(1,an1n0) = n1
 344           somare(2,an1n0) = n0
 345           somare(1,an2n0) = n2
 346           somare(2,an2n0) = n0
 347           somare(1,an3n0) = n3
 348           somare(2,an3n0) = n0
 349           somare(1,an4n0) = n4
 350           somare(2,an4n0) = n0
 351 #ifdef _DEBUG_HOMARD_
 352            write (ulsort,texte(langue,6)) an1n0, n1, n0
 353            write (ulsort,texte(langue,6)) an2n0, n2, n0
 354            write (ulsort,texte(langue,6)) an3n0, n3, n0
 355            write (ulsort,texte(langue,6)) an4n0, n4, n0
 356 #endif
 357 c
 358 c 1.6.3. ==> leur famille
 359 c
 360 cgn      write(ulsort,90002) 'famqua(lequad)',famqua(lequad)
 361 cgn      write(ulsort,90002) 'avec cfaqua',
 362 cgn     >(cfaqua(iaux,famqua(lequad)),iaux=1,nctfqu)
 363 cgn      write(ulsort,90002) '==> famare', cfaqua(cofafa,famqua(lequad))
 364           jaux = cfaqua(cofafa,famqua(lequad))
 365           famare(an1n0) = jaux
 366           famare(an2n0) = jaux
 367           famare(an3n0) = jaux
 368           famare(an4n0) = jaux
 369 c
 370 c 1.6.4. ==> la parente
 371 c
 372           hetare(an1n0) = 50
 373           hetare(an2n0) = 50
 374           hetare(an3n0) = 50
 375           hetare(an4n0) = 50
 376           merare(an1n0) = 0
 377           merare(an2n0) = 0
 378           merare(an3n0) = 0
 379           merare(an4n0) = 0
 380           filare(an1n0) = 0
 381           filare(an2n0) = 0
 382           filare(an3n0) = 0
 383           filare(an4n0) = 0
 384 c
 385 c 1.7. ==> creation des 4 quadrangles fils
 386 c 1.7.1. ==> connectivite
 387 c            on prend soin de tourner dans le meme sens que le pere ...
 388 c
 389           nf1 = indqua + 1
 390           arequa(nf1,1) = a1f1
 391           arequa(nf1,2) = an1n0
 392           arequa(nf1,3) = an4n0
 393           arequa(nf1,4) = a4f2
 394 c
 395           nf2 = nf1 + 1
 396           arequa(nf2,1) = a2f1
 397           arequa(nf2,2) = an2n0
 398           arequa(nf2,3) = an1n0
 399           arequa(nf2,4) = a1f2
 400 c
 401           nf3 = nf2 + 1
 402           arequa(nf3,1) = a3f1
 403           arequa(nf3,2) = an3n0
 404           arequa(nf3,3) = an2n0
 405           arequa(nf3,4) = a2f2
 406 c
 407           nf4 = nf3 + 1
 408           arequa(nf4,1) = a4f1
 409           arequa(nf4,2) = an4n0
 410           arequa(nf4,3) = an3n0
 411           arequa(nf4,4) = a3f2
 412 c
 413           indqua = nf4
 414 c
 415 #ifdef _DEBUG_HOMARD_
 416            write (ulsort,texte(langue,7)) nf1, a1f1, an1n0, an4n0, a4f2
 417            write (ulsort,texte(langue,7)) nf2, a2f1, an2n0, an1n0, a1f2
 418            write (ulsort,texte(langue,7)) nf3, a3f1, an3n0, an2n0, a2f2
 419            write (ulsort,texte(langue,7)) nf4, a4f1, an4n0, an3n0, a3f2
 420 #endif
 421 cgn  cgn      write (ulsort,90002) '... nf1', nf1
 422 cgn        do 171 , iaux = 1,4
 423 cgn          write (ulsort,17)arequa(nf1,iaux),
 424 cgn     <  somare(1,arequa(nf1,iaux)),somare(2,arequa(nf1,iaux))
 425 cgn  171   continue
 426 cgn  cgn      write (ulsort,90002) '... nf2', nf2
 427 cgn        do 172 , iaux = 1,4
 428 cgn          write (ulsort,17)arequa(nf2,iaux),
 429 cgn     <  somare(1,arequa(nf2,iaux)),somare(2,arequa(nf2,iaux))
 430 cgn  172   continue
 431 cgn  cgn      write (ulsort,90002) '... nf3', nf3
 432 cgn        do 173 , iaux = 1,4
 433 cgn          write (ulsort,17)arequa(nf3,iaux),
 434 cgn     <  somare(1,arequa(nf3,iaux)),somare(2,arequa(nf3,iaux))
 435 cgn  173   continue
 436 cgn  cgn      write (ulsort,90002) '... nf4', nf4
 437 cgn        do 174 , iaux = 1,4
 438 cgn          write (ulsort,17)arequa(nf4,iaux),
 439 cgn     <  somare(1,arequa(nf4,iaux)),somare(2,arequa(nf4,iaux))
 440 cgn  174   continue
 441 cgn  17      format('.... arete ',i6,' de ',i6,' a ',i6)
 442 c
 443 c 1.7.2. ==> mise a jour de la famille des 4 quadrangles fils
 444 c
 445           iaux = famqua(lequad)
 446           famqua(nf1) = iaux
 447           famqua(nf2) = iaux
 448           famqua(nf3) = iaux
 449           famqua(nf4) = iaux
 450 c
 451           hetqua(nf1) = 5500
 452           hetqua(nf2) = 5500
 453           hetqua(nf3) = 5500
 454           hetqua(nf4) = 5500
 455 c
 456           filqua(nf1) = 0
 457           filqua(nf2) = 0
 458           filqua(nf3) = 0
 459           filqua(nf4)  = 0
 460           perqua(nf1) = lequad
 461           perqua(nf2) = lequad
 462           perqua(nf3) = lequad
 463           perqua(nf4) = lequad
 464 c
 465           niv = nivqua(lequad) + 1
 466           nivqua(nf1) = niv
 467           nivqua(nf2) = niv
 468           nivqua(nf3) = niv
 469           nivqua(nf4) = niv
 470 c
 471 c 1.8. ==> mise a jour du pere et du grand-pere eventuel
 472 c    Remarque : si on est parti d'un macro-maillage non conforme,
 473 c               certains quadrangles ont des peres adoptifs de numero
 474 c               negatif. Il ne faut pas changer leur etat
 475 c
 476           filqua(lequad) = nf1
 477           hetqua(lequad) = hetqua(lequad) + 4
 478           lepere = perqua(lequad)
 479           if ( lepere.gt.0 ) then
 480             etat = hetqua(lepere)
 481             hetqua(lepere) = etat - mod(etat,100) + 99
 482           endif
 483 cgn      write (ulsort,90002)'.. indqua',indqua
 484 cgn      write (ulsort,90002)'.. indare',indare
 485 c
 486         endif
 487 c
 488   100 continue
 489 cgn      write (ulsort,*) 'indqua',indqua
 490 cgn      write (ulsort,*) 'indare',indare
 491 cgn      write (ulsort,*) 'indnoe',indnoe
 492 c
 493 #ifdef _DEBUG_HOMARD_
 494         write (ulsort,*) 'sortie de ',nompro
 495         do 1102 , iaux = 1 , min(nouvar,1)
 496           write (ulsort,90001) 'arete', iaux,
 497      >    somare(1,iaux), somare(2,iaux)
 498  1102   continue
 499         do 1106 , lequad = 1 , min(nouvqu,1)
 500           write (ulsort,90001) 'quadrangle', lequad,
 501      >    arequa(lequad,1), arequa(lequad,2),
 502      >    arequa(lequad,3), arequa(lequad,4)
 503  1106   continue
 504           lequad = 1
 505           write (ulsort,90001) 'fils du quadrangle', lequad,
 506      >    filqua(lequad)
 507 #endif
 508 c
 509 c====
 510 c 3. la fin
 511 c====
 512 c
 513       if ( codret.ne.0 ) then
 514 c
 515 #include "envex2.h"
 516 c
 517       write (ulsort,texte(langue,1)) 'Sortie', nompro
 518       write (ulsort,texte(langue,2)) codret
 519 c
 520       endif
 521 c
 522 #ifdef _DEBUG_HOMARD_
 523       write (ulsort,texte(langue,1)) 'Sortie', nompro
 524       call dmflsh (iaux)
 525 #endif
 526 c
 527       end