src/tool/Suivi_Frontiere/sfcot2.F

   1       subroutine sfcot2 ( nbcoqu, nbcoar,
   2      >                    coonoe,
   3      >                    somare, filare, np2are,
   4      >                    cfaare, famare,
   5      >                    facare, posifa,
   6      >                    hettri, aretri, filtri,
   7      >                    hetqua, arequa, filqua,
   8      >                    cfaqua, famqua,
   9      >                    tritet, cotrte, aretet, hettet,
  10      >                    filtet,
  11      >                    quahex, coquhe, arehex, hethex,
  12      >                    filhex,
  13      >                    facpyr, cofapy, arepyr, hetpyr,
  14      >                    facpen, cofape, arepen, hetpen,
  15      >                    voltri, pypetr,
  16      >                    volqua, pypequ,
  17      >                    nbarfr, arefro,
  18      >                    nbqufr, quafro,
  19      >                    ulsort, langue, codret)
  20 c ______________________________________________________________________
  21 c                             H O M A R D
  22 c
  23 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  24 c
  25 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  26 c aupres des huissiers de justice Simart et Lavoir a Clamart
  27 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  28 c aupres des huissiers de justice
  29 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  30 c
  31 c    HOMARD est une marque deposee d'Electricite de France
  32 c
  33 c Copyright EDF 1996
  34 c Copyright EDF 1998
  35 c Copyright EDF 2002
  36 c Copyright EDF 2020
  37 c ______________________________________________________________________
  38 c
  39 c   Suivi de Frontiere - COnTroles - phase 2
  40 c   -        -           -- -              -
  41 c ______________________________________________________________________
  42 c .        .     .        .                                            .
  43 c .  nom   . e/s . taille .           description                      .
  44 c .____________________________________________________________________.
  45 c . nbcoqu .   s .   1    . nombre de corrections pour les quadrangles .
  46 c . nbcoar .   s .   1    . nombre de corrections pour les aretes      .
  47 c . coonoe . es  . nbnoto . coordonnees des noeuds                     .
  48 c .        .     . *sdim  .                                            .
  49 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  50 c . filare . e   . nbarto . premiere fille des aretes                  .
  51 c . np2are . e   . nbarto . noeud milieux des aretes                   .
  52 c . cfaare . e   . nctfar*. codes des familles des aretes              .
  53 c .        .     . nbfare .   1 : famille MED                          .
  54 c .        .     .        .   2 : type de segment                      .
  55 c .        .     .        .   3 : orientation                          .
  56 c .        .     .        .   4 : famille d'orientation inverse        .
  57 c .        .     .        .   5 : numero de ligne de frontiere         .
  58 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
  59 c .        .     .        . <= 0 si non concernee                      .
  60 c .        .     .        .   6 : famille frontiere active/inactive    .
  61 c .        .     .        .   7 : numero de surface de frontiere       .
  62 c .        .     .        . + l : appartenance a l'equivalence l       .
  63 c . famare . e   . nbarto . famille des aretes                         .
  64 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  65 c . posifa . e   . nbarto . pointeur sur tableau facare                .
  66 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  67 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  68 c . filtri . e   . nbtrto . premier fils des triangles                 .
  69 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  70 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  71 c . filqua . e   . nbquto . premier fils des quadrangles               .
  72 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
  73 c .        .     . nbfqua .   1 : famille MED                          .
  74 c .        .     .        .   2 : type de quadrangle                   .
  75 c .        .     .        .   3 : numero de surface de frontiere       .
  76 c .        .     .        .   4 : famille des aretes internes apres raf.
  77 c .        .     .        .   5 : famille des triangles de conformite  .
  78 c .        .     .        .   6 : famille de sf active/inactive        .
  79 c .        .     .        . + l : appartenance a l'equivalence l       .
  80 c . famqua . e   . nbquto . famille des quadrangles                    .
  81 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  82 c . cotrte . e   .nbtecf*4. code des 4 triangles des tetraedres        .
  83 c . aretet . e   .nbteca*6. numeros des 6 aretes des tetraedres        .
  84 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  85 c . filtet . e   . nbteto . premier fils des tetraedres                .
  86 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  87 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  88 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
  89 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  90 c . filhex . e   . nbheto . premier fils des hexaedres                 .
  91 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  92 c . cofapy . e   .nbpycf*5. codes des faces des pyramides              .
  93 c . arepyr . e   .nbpyca*8. numeros des 8 aretes des pyramides         .
  94 c . hetpyr . e   . nbpyto . historique de l'etat des pyramides         .
  95 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  96 c . cofape . e   .nbpecf*5. code des 5 faces des pentaedres            .
  97 c . arepen . e   .nbpeca*9. numeros des 9 aretes des pentaedres        .
  98 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  99 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
 100 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
 101 c .        .     .        .   0 : pas de voisin                        .
 102 c .        .     .        . j>0 : tetraedre j                          .
 103 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
 104 c . pypetr . e   .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
 105 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
 106 c .        .     .        . pypetr(2,j) = numero du pentaedre voisin   .
 107 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
 108 c . volqua . e   .2*nbquto. numeros des 2 volumes par quadrangle       .
 109 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
 110 c .        .     .        .   0 : pas de voisin                        .
 111 c .        .     .        . j>0 : hexaedre j                           .
 112 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
 113 c . pypequ . e   .2*lgpype. pypequ(1,j) = numero de la pyramide voisine.
 114 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
 115 c .        .     .        . pypequ(2,j) = numero du pentaedre voisin   .
 116 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
 117 c . nbarfr . e   .   1    . nombre d'aretes concernees                 .
 118 c . arefro . es  . nbarfr . liste des aretes concernees                .
 119 c . nbqufr . e   .   1    . nombre de quadrangles concernes            .
 120 c . quafro . es  . nbqufr . liste des quadrangles concernes            .
 121 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 122 c . langue . e   .    1   . langue des messages                        .
 123 c .        .     .        . 1 : francais, 2 : anglais                  .
 124 c . codret . es  .    1   . code de retour des modules                 .
 125 c .        .     .        . 0 : pas de probleme                        .
 126 c .        .     .        . x : probleme                               .
 127 c ______________________________________________________________________
 128 c
 129 c====
 130 c 0. declarations et dimensionnement
 131 c====
 132 c
 133 c 0.1. ==> generalites
 134 c
 135       implicit none
 136       save
 137 c
 138       character*6 nompro
 139       parameter ( nompro = 'SFCOT2' )
 140 c
 141 #include "nblang.h"
 142 c
 143 c 0.2. ==> communs
 144 c
 145 #include "envex1.h"
 146 c
 147 #include "envca1.h"
 148 #include "dicfen.h"
 149 #include "nbfami.h"
 150 #include "nombno.h"
 151 #include "nombar.h"
 152 #include "nombqu.h"
 153 #include "nombtr.h"
 154 #include "nombte.h"
 155 #include "nombhe.h"
 156 #include "nombpy.h"
 157 #include "nombpe.h"
 158 #include "impr02.h"
 159 c
 160 c 0.3. ==> arguments
 161 c
 162       integer nbcoar, nbcoqu
 163       integer somare(2,nbarto), filare(nbarto), np2are(nbarto)
 164       integer posifa(0:nbarto), facare(nbfaar)
 165       integer cfaare(nctfar,nbfare), famare(nbarto)
 166       integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto)
 167       integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto)
 168       integer cfaqua(nctfqu,nbfqua), famqua(nbquto)
 169       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
 170       integer hettet(nbteto)
 171       integer filtet(nbteto)
 172       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
 173       integer hethex(nbheto)
 174       integer filhex(nbheto)
 175       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
 176       integer hetpyr(nbpyto)
 177       integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
 178       integer hetpen(nbpeto)
 179       integer voltri(2,nbtrto), pypetr(2,*)
 180       integer volqua(2,nbquto), pypequ(2,*)
 181       integer nbarfr, arefro(nbarfr)
 182       integer nbqufr, quafro(nbqufr)
 183 c
 184       double precision coonoe(nbnoto,sdim)
 185 c
 186       integer ulsort, langue, codret
 187 c
 188 c 0.4. ==> variables locales
 189 c
 190       integer iaux
 191 c
 192       integer nbcoa2, nbcoq2
 193 c
 194       integer nbmess
 195       parameter ( nbmess = 10 )
 196       character*80 texte(nblang,nbmess)
 197 c
 198 c 0.5. ==> initialisations
 199 c ______________________________________________________________________
 200 c
 201 c====
 202 c 1. initialisations
 203 c====
 204 c
 205 c 1.1. ==> les messages
 206 c
 207 #include "impr01.h"
 208 c
 209 #ifdef _DEBUG_HOMARD_
 210       write (ulsort,texte(langue,1)) 'Entree', nompro
 211       call dmflsh (iaux)
 212 #endif
 213 c
 214       texte(1,5) = '(''. Apres controle par interpenetration :'')'
 215       texte(1,8) =
 216      >'(''==> Nombre de corrections de noeuds lies a des '',a,'':'',
 217      >i10)'
 218       texte(1,9) = '(''==> Tout va bien.'')'
 219       texte(1,10) = '(''Nombre de '',a,''concernes :'',i10)'
 220 c
 221       texte(2,5) = '(''. After checking of connections :'')'
 222       texte(2,8) =
 223      >'(''==> Number of corrections of nodes connected to '',a,'':'',
 224      >i10)'
 225       texte(2,9) = '(''==> Everything is OK.'')'
 226       texte(2,10) = '(''Number of involved '',a,'':'',i10)'
 227 c
 228       codret = 0
 229 c
 230 c====
 231 c 2. Controle des aretes et quadrangles qui viennent d'etre decoupes et
 232 c    qui font partie d'une frontiere reconnue
 233 c====
 234 #ifdef _DEBUG_HOMARD_
 235       write (ulsort,*) '2. controle ; codret = ', codret
 236 #endif
 237 c
 238       nbcoar = 0
 239       nbcoqu = 0
 240 c
 241 #ifdef _DEBUG_HOMARD_
 242       write (ulsort,texte(langue,10)) mess14(langue,3,1), nbarfr
 243       write (ulsort,texte(langue,10)) mess14(langue,3,4), nbqufr
 244 cgn      write (ulsort,*) quafro
 245 #endif
 246 c
 247 c 2.1. ==> Les pyramides
 248 cgn      call gtdems (74)
 249 c
 250       if ( codret.eq.0 ) then
 251 c
 252       if ( nbpyto.ne.0 ) then
 253 c
 254 #ifdef _DEBUG_HOMARD_
 255       write (ulsort,texte(langue,3)) 'UTB3F1', nompro
 256 #endif
 257         call utb3f1 ( nbcoq2, nbcoa2,
 258      >                coonoe,
 259      >                somare, filare, np2are,
 260      >                cfaare, famare,
 261      >                aretri,
 262      >                arequa, filqua,
 263      >                cfaqua, famqua,
 264      >                hetpyr, facpyr, cofapy, arepyr,
 265      >                nbarfr, arefro,
 266      >                nbqufr, quafro,
 267      >                ulsort, langue, codret )
 268 c
 269         if ( codret.eq.0 ) then
 270 c
 271          nbcoqu = nbcoqu + nbcoq2
 272          nbcoar = nbcoar + nbcoa2
 273 c
 274         endif
 275 c
 276       endif
 277 c
 278       endif
 279 c
 280 c 2.2. ==> Les pentaedres
 281 c
 282       if ( codret.eq.0 ) then
 283 c
 284       if ( nbpeto.ne.0 ) then
 285 c
 286 #ifdef _DEBUG_HOMARD_
 287       write (ulsort,texte(langue,3)) 'UTB3G1', nompro
 288 #endif
 289         call utb3g1 ( nbcoq2, nbcoa2,
 290      >                coonoe,
 291      >                somare, filare, np2are,
 292      >                cfaare, famare,
 293      >                arequa, filqua,
 294      >                cfaqua, famqua,
 295      >                hetpen, facpen, cofape, arepen,
 296      >                nbarfr, arefro,
 297      >                nbqufr, quafro,
 298      >                ulsort, langue, codret )
 299 c
 300         if ( codret.eq.0 ) then
 301 c
 302          nbcoqu = nbcoqu + nbcoq2
 303          nbcoar = nbcoar + nbcoa2
 304 c
 305         endif
 306 c
 307       endif
 308 c
 309       endif
 310 cgn      call gtfims (74)
 311 c
 312 c 2.3. ==> Les tetraaedres
 313 cgn      call gtdems (75)
 314 c
 315       if ( codret.eq.0 ) then
 316 c
 317       if ( nbteto.ne.0 ) then
 318 c
 319 #ifdef _DEBUG_HOMARD_
 320       write (ulsort,texte(langue,3)) 'UTB3D1', nompro
 321 #endif
 322         call utb3d1 ( nbcoq2, nbcoa2,
 323      >                coonoe,
 324      >                somare, filare, np2are,
 325      >                cfaare, famare,
 326      >                aretri,
 327      >                hettet, tritet, cotrte, aretet,
 328      >                nbarfr, arefro,
 329      >                nbqufr, quafro,
 330      >                ulsort, langue, codret )
 331 c
 332         if ( codret.eq.0 ) then
 333 c
 334          nbcoqu = nbcoqu + nbcoq2
 335          nbcoar = nbcoar + nbcoa2
 336 c
 337         endif
 338 c
 339       endif
 340 c
 341       endif
 342 cgn      call gtfims (75)
 343 c
 344 c 2.4. ==> Les hexaedres
 345 c
 346 cgn      call gtdems (76)
 347       if ( codret.eq.0 ) then
 348 c
 349       if ( nbheto.ne.0 ) then
 350 c
 351 #ifdef _DEBUG_HOMARD_
 352       write (ulsort,texte(langue,3)) 'UTB3E1', nompro
 353 #endif
 354         call utb3e1 ( nbcoq2, nbcoa2,
 355      >                coonoe,
 356      >                somare, filare, np2are,
 357      >                cfaare, famare,
 358      >                arequa, filqua,
 359      >                cfaqua, famqua,
 360      >                hethex, quahex, coquhe, arehex,
 361      >                nbarfr, arefro,
 362      >                nbqufr, quafro,
 363      >                ulsort, langue, codret )
 364 c
 365         if ( codret.eq.0 ) then
 366 c
 367          nbcoqu = nbcoqu + nbcoq2
 368          nbcoar = nbcoar + nbcoa2
 369 c
 370         endif
 371 c
 372       endif
 373 c
 374       endif
 375 cgn      call gtfims (76)
 376 c
 377 c====
 378 c 3. La fin
 379 c====
 380 c
 381 #ifdef _DEBUG_HOMARD_
 382       write (ulsort,texte(langue,5))
 383       if ( (nbcoqu+nbcoar).eq.0 ) then
 384         write (ulsort,texte(langue,9))
 385       else
 386         if ( nbcoqu.gt.0 ) then
 387           write (ulsort,texte(langue,8)) mess14(langue,3,4), nbcoqu
 388         endif
 389         if ( nbcoar.gt.0 ) then
 390           write (ulsort,texte(langue,8)) mess14(langue,3,1), nbcoar
 391         endif
 392       endif
 393 #endif
 394 c
 395       if ( codret.ne.0 ) then
 396 c
 397 #include "envex2.h"
 398 c
 399       write (ulsort,texte(langue,1)) 'Sortie', nompro
 400       write (ulsort,texte(langue,2)) codret
 401 c
 402       endif
 403 c
 404 #ifdef _DEBUG_HOMARD_
 405       write (ulsort,texte(langue,1)) 'Sortie', nompro
 406       call dmflsh (iaux)
 407 #endif
 408 c
 409       end