src/tool/AP_Conversion/pcmar0.F

   1       subroutine pcmar0 ( nonexm,
   2      >                    hetare, filare, merare,
   3      >                    famare, posifa, facare,
   4      >                    aretri, hettri, nivtri,
   5      >                    famtri, pertri, filtri,
   6      >                    arequa, hetqua, nivqua,
   7      >                    famqua, perqua, filqua,
   8      >                    hettet,
   9      >                    hethex,
  10      >                    hetpyr,
  11      >                    voltri, pypetr,
  12      >                    volqua, pypequ,
  13      >                    nbanci, nbenrc, numead,
  14      >                    arreca, trreca, qureca,
  15      >                    nparrc, nptrrc, npqurc,
  16      >                    npterc, npherc, npperc, nppyrc,
  17      >                    arerec, trirec, quarec,
  18      >                    tetrec, hexrec, penrec, pyrrec,
  19      >                    ulsort, langue, codret )
  20 c ______________________________________________________________________
  21 c
  22 c                             H O M A R D
  23 c
  24 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  25 c
  26 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  27 c aupres des huissiers de justice Simart et Lavoir a Clamart
  28 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  29 c aupres des huissiers de justice
  30 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  31 c
  32 c    HOMARD est une marque deposee d'Electricite de France
  33 c
  34 c Copyright EDF 1996
  35 c Copyright EDF 1998
  36 c Copyright EDF 2002
  37 c Copyright EDF 2020
  38 c ______________________________________________________________________
  39 c
  40 c    aPres adaptation - Conversion de MAillage - Recollements - phase 0
  41 c     -                 -             --         -                    -
  42 c    Reperage des faces de raccordement non conforme
  43 c ______________________________________________________________________
  44 c .        .     .        .                                            .
  45 c .  nom   . e/s . taille .           description                      .
  46 c .____________________________________________________________________.
  47 c . nonexm . e   .    1   . non exportation de mailles                 .
  48 c .        .     .        .   1 : on exporte toutes les mailles        .
  49 c .        .     .        .  2x : les segments ne sont pas exportes    .
  50 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  51 c . filare . e   . nbarto . fille ainee de chaque arete                .
  52 c . merare . e   . nbarto . mere de chaque arete                       .
  53 c . famare . es  . nbarto . famille des aretes                         .
  54 c . posifa . e   .0:nbarto. pointeur sur tableau facare                .
  55 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  56 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  57 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  58 c . nivtri . e   . nbtrto . niveau des triangles                       .
  59 c . famtri . es  . nbtrto . famille des triangles                      .
  60 c . pertri . e   . nbtrto . pere des triangles                         .
  61 c . filtri . e   . nbtrto . fils des triangles                         .
  62 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  63 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  64 c . nivqua . e   . nbquto . niveau des quadrangles                     .
  65 c . famqua . es  . nbquto . famille des quadrangles                    .
  66 c . perqua . e   . nbquto . pere des quadrangles                       .
  67 c . filqua . e   . nbquto . fils des quadrangles                       .
  68 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  69 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  70 c . hetpyr . e   . nbpyto . historique de l'etat des pyramides         .
  71 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
  72 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
  73 c .        .     .        .   0 : pas de voisin                        .
  74 c .        .     .        . j>0 : tetraedre j                          .
  75 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
  76 c . pypetr . e   .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
  77 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  78 c .        .     .        . pypetr(2,j) = numero du pentaedre voisin   .
  79 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  80 c . volqua . e   .2*nbquto. numeros des 2 volumes par quadrangle       .
  81 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
  82 c .        .     .        .   0 : pas de voisin                        .
  83 c .        .     .        . j>0 : hexaedre j                           .
  84 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
  85 c . pypequ . e   .2*lgpype. pypequ(1,j) = numero de la pyramide voisine.
  86 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
  87 c .        .     .        . pypequ(2,j) = numero du pentaedre voisin   .
  88 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
  89 c . nbanci . e   .    1   . nombre de non conformites initiales        .
  90 c . nbenrc . e   .    1   . nombre d'entites par recollement unitaire  .
  91 c . numead . e   .   1    . numero de la mere adoptive                 .
  92 c . arreca . e   .2*nbanci. liste des aretes recouvrant une autre      .
  93 c . nparrc .  s  .   1    . nombre de paires d'aretes a recoller       .
  94 c . nptrrc .  s  .   1    . nombre de paires de triangles a recoller   .
  95 c . npqurc .  s  .   1    . nombre de paires de quadrangles a recoller .
  96 c . npterc .  s  .   1    . nombre de paires de tetraedres recolles    .
  97 c . npherc .  s  .   1    . nombre de paires d'hexaedres recolles      .
  98 c . npperc .  s  .   1    . nombre de paires de pentaedres recolles    .
  99 c . nppyrc .  s  .   1    . nombre de paires de pyramides recollees    .
 100 c . arerec .  s  .  2*x   . paires des aretes a recoller               .
 101 c . trirec .  s  .  2*x   . paires des triangles a recoller            .
 102 c . quarec .  s  .  2*x   . paires des quadrangles a recoller          .
 103 c . tetrec .  s  .  3*x   . paires des tetra. voisins faces a recoller .
 104 c . hexrec .  s  .  3*x   . paires des hexa. voisins faces a recoller  .
 105 c . penrec .  s  .  3*x   . paires des penta. voisins faces a recoller .
 106 c . pyrrec .  s  .  3*x   . paires des pyram. voisines faces a recoller.
 107 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 108 c . langue . e   .    1   . langue des messages                        .
 109 c .        .     .        . 1 : francais, 2 : anglais                  .
 110 c . codret . es  .    1   . code de retour des modules                 .
 111 c .        .     .        . 0 : pas de probleme                        .
 112 c .        .     .        . 1 : probleme                               .
 113 c ______________________________________________________________________
 114 c
 115 c====
 116 c 0. declarations et dimensionnement
 117 c====
 118 c
 119 c 0.1. ==> generalites
 120 c
 121       implicit none
 122       save
 123 c
 124       character*6 nompro
 125       parameter ( nompro = 'PCMAR0' )
 126 c
 127 #include "nblang.h"
 128 c
 129 c 0.2. ==> communs
 130 c
 131 #include "envex1.h"
 132 c
 133 #include "nbfami.h"
 134 #include "nombar.h"
 135 #include "nombtr.h"
 136 #include "nombqu.h"
 137 #include "nombte.h"
 138 #include "nombhe.h"
 139 #include "nombpy.h"
 140 #include "impr02.h"
 141 c
 142 c 0.3. ==> arguments
 143 c
 144       integer nonexm
 145 c
 146       integer hetare(nbarto), filare(nbarto), merare(nbarto)
 147       integer famare(nbarto)
 148       integer posifa(0:nbarto), facare(nbfaar)
 149       integer aretri(nbtrto,3), hettri(nbtrto), nivtri(nbtrto)
 150       integer famtri(nbtrto), pertri(nbtrto), filtri(nbtrto)
 151       integer arequa(nbquto,4), hetqua(nbquto), nivqua(nbquto)
 152       integer famqua(nbquto), perqua(nbquto),filqua(nbquto)
 153       integer hettet(nbteto)
 154       integer hethex(nbheto)
 155       integer hetpyr(nbpyto)
 156       integer voltri(2,nbtrto), pypetr(2,*)
 157       integer volqua(2,nbquto), pypequ(2,*)
 158       integer nbanci, nbenrc, numead
 159       integer arreca(nbenrc*nbanci)
 160       integer nparrc, nptrrc, npqurc
 161       integer npterc, npherc, npperc, nppyrc
 162       integer trreca(nbtrri)
 163       integer qureca(nbquri)
 164       integer arerec(2,*), trirec(2,*), quarec(2,*)
 165       integer tetrec(3,*), hexrec(3,*), penrec(3,*), pyrrec(3,*)
 166 c
 167       integer ulsort, langue, codret
 168 c
 169 c 0.4. ==> variables locales
 170 c
 171       integer iaux
 172 c
 173       integer nbmess
 174       parameter ( nbmess = 30 )
 175       character*80 texte(nblang,nbmess)
 176 c
 177 c 0.5. ==> initialisations
 178 c ______________________________________________________________________
 179 c
 180 c====
 181 c 1. messages
 182 c====
 183 c
 184 #include "impr01.h"
 185 c
 186 #ifdef _DEBUG_HOMARD_
 187       write (ulsort,texte(langue,1)) 'Entree', nompro
 188       call dmflsh (iaux)
 189 #endif
 190 c
 191       texte(1,4) = '(''On ne devrait pas passer dans '',a)'
 192       texte(1,5) = '(''Examen du '',a,''numero '',i10)'
 193       texte(1,6) =
 194      > '(2x,''Nombre de paires de '',a,''a recoller :'',i10)'
 195       texte(1,8) =
 196      > '(''.. Modification de la famille du '',a,''numero '',i10)'
 197       texte(1,9) =
 198      > '(''.. Modification de l''''etat du '',a,''numero '',i10)'
 199       texte(1,10) = '(5x,''==> avant :'',i5,'', apres :'',i5)'
 200       texte(1,11) = '(''Nombre de non-conformites initiales :'',i10))'
 201       texte(1,12) = '(''. de fils :'',2i10))'
 202       texte(1,13) = '(''. Etat du '',a,''numero '',i10,'' :'',i10)'
 203 c
 204       texte(2,4) = '(a,'' should not be called.'')'
 205       texte(2,5) = '(''Examination of '',a,'',# '',i10)'
 206       texte(2,6) = '(2x,''Number of pairs of '',a,''to glue :'',i10)'
 207       texte(2,8) =
 208      > '(''.. Modification of the family of '',a,'',# '',i10)'
 209       texte(2,9) =
 210      > '(''.. Modification of the state of '',a,'',# '',i10)'
 211       texte(2,10) = '(5x,''==> old :'',i5,'', new :'',i5)'
 212       texte(2,11) = '(''Number of non-conformal situations :'',i10))'
 213       texte(2,12) = '(''. with sons :'',2i10))'
 214       texte(2,13) = '(''. State for '',a,''# '',i10,'' :'',i10)'
 215 c
 216 #include "impr03.h"
 217 c
 218       codret = 0
 219 c
 220       nparrc = 0
 221       nptrrc = 0
 222       npqurc = 0
 223       npterc = 0
 224       npherc = 0
 225       npperc = 0
 226       nppyrc = 0
 227 c
 228 c====
 229 c 2. Les aretes
 230 c====
 231 c
 232       if ( mod(nonexm,2).ne.0 ) then
 233 c
 234         if ( codret.eq.0 ) then
 235 c
 236 #ifdef _DEBUG_HOMARD_
 237       write (ulsort,texte(langue,3)) 'PCMAR2', nompro
 238 #endif
 239         call pcmar2 ( hetare, filare, merare,
 240      >                famare, posifa, facare,
 241      >                aretri, hettri, nivtri,
 242      >                voltri,
 243      >                arequa, hetqua, nivqua,
 244      >                nbanci, nbenrc,
 245      >                arreca,
 246      >                nparrc, arerec,
 247      >                ulsort, langue, codret )
 248 c
 249         endif
 250 c
 251       endif
 252 c
 253 c====
 254 c 3. Les triangles
 255 c====
 256 #ifdef _DEBUG_HOMARD_
 257       write (ulsort,90002) '3. Les triangles ; codret', codret
 258 #endif
 259 c
 260       if ( nbtrto.ne.0 ) then
 261 c
 262         if ( codret.eq.0 ) then
 263 c
 264         iaux = 2
 265 #ifdef _DEBUG_HOMARD_
 266         write (ulsort,texte(langue,3)) 'PCMAR3_tr', nompro
 267 #endif
 268         call pcmar3 (   iaux, numead,
 269      >                nbtrto, nbteto, nbftri,
 270      >                hettri, nivtri,
 271      >                famtri, pertri, filtri,
 272      >                hettet, hetpyr,
 273      >                voltri, pypetr,
 274      >                nbtrri, trreca,
 275      >                nptrrc, trirec,
 276      >                npterc, tetrec, npperc, penrec, nppyrc, pyrrec,
 277      >                ulsort, langue, codret )
 278 c
 279         endif
 280 c
 281       endif
 282 c
 283 c====
 284 c 4. Les quadrangles
 285 c====
 286 #ifdef _DEBUG_HOMARD_
 287       write (ulsort,90002) '4. Les quadrangles ; codret', codret
 288 #endif
 289 c
 290       if ( nbquto.ne.0 ) then
 291 c
 292         if ( codret.eq.0 ) then
 293 c
 294         iaux = 4
 295 #ifdef _DEBUG_HOMARD_
 296       write (ulsort,texte(langue,3)) 'PCMAR3_qu', nompro
 297 #endif
 298         call pcmar3 (   iaux, numead,
 299      >                nbquto, nbheto, nbfqua,
 300      >                hetqua, nivqua,
 301      >                famqua, perqua, filqua,
 302      >                hethex, hetpyr,
 303      >                volqua, pypequ,
 304      >                nbquri, qureca,
 305      >                npqurc, quarec,
 306      >                npherc, hexrec, npperc, penrec, nppyrc, pyrrec,
 307      >                ulsort, langue, codret )
 308 c
 309         endif
 310 c
 311       endif
 312 c
 313 c====
 314 c 5. Bilan
 315 c====
 316 #ifdef _DEBUG_HOMARD_
 317 c
 318       if ( codret.eq.0 ) then
 319 c
 320       if ( mod(nonexm,2).ne.0 ) then
 321         write (ulsort,texte(langue,6)) mess14(langue,3,1), nparrc
 322       endif
 323       write (ulsort,texte(langue,6)) mess14(langue,3,2), nptrrc
 324       write (ulsort,texte(langue,6)) mess14(langue,3,4), npqurc
 325       write (ulsort,*) ' '
 326 c
 327       endif
 328 #endif
 329 c
 330 c====
 331 c 6. la fin
 332 c====
 333 c
 334 cgn      iaux = 12274
 335 cgn          write (ulsort,texte(langue,5)) mess14(langue,1,2), iaux
 336 cgn          write (ulsort,*) 'etat    = ',hettri(iaux),
 337 cgn     >                     ', famille = ',famtri(iaux)
 338 cgn      iaux = 31599
 339 cgn          write (ulsort,texte(langue,5)) mess14(langue,1,2), iaux
 340 cgn          write (ulsort,*) 'etat    = ',hettri(iaux),
 341 cgn     >                     ', famille = ',famtri(iaux)
 342 #ifdef _DEBUG_HOMARD_
 343       write (ulsort,*) '6. la fin ; codret = ', codret
 344 #endif
 345 c
 346       if ( codret.ne.0 ) then
 347 c
 348 #include "envex2.h"
 349 c
 350       write (ulsort,texte(langue,1)) 'Sortie', nompro
 351       write (ulsort,texte(langue,2)) codret
 352 c
 353       endif
 354 c
 355 #ifdef _DEBUG_HOMARD_
 356       write (ulsort,texte(langue,1)) 'Sortie', nompro
 357       call dmflsh (iaux)
 358 #endif
 359 c
 360       end