src/tool/Suivi_Frontiere/sfcotl.F

   1       subroutine sfcotl ( coonoe,
   2      >                    somare, filare, np2are,
   3      >                    cfaare, famare,
   4      >                    facare, posifa,
   5      >                    hettri, aretri, filtri,
   6      >                    hetqua, arequa, filqua,
   7      >                    cfaqua, famqua,
   8      >                    tritet, cotrte, aretet, hettet,
   9      >                    filtet,
  10      >                    quahex, coquhe, arehex, hethex,
  11      >                    filhex,
  12      >                    facpyr, cofapy, arepyr, hetpyr,
  13      >                    facpen, cofape, arepen, hetpen,
  14      >                    voltri, pypetr,
  15      >                    volqua, pypequ,
  16      >                    nbarfr, arefro,
  17      >                    nbqufr, quafro,
  18      >                    lgetco, taetco,
  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
  40 c   -        -           -- -  -
  41 c ______________________________________________________________________
  42 c .        .     .        .                                            .
  43 c .  nom   . e/s . taille .           description                      .
  44 c .____________________________________________________________________.
  45 c . coonoe . es  . nbnoto . coordonnees des noeuds                     .
  46 c .        .     . *sdim  .                                            .
  47 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  48 c . filare . e   . nbarto . premiere fille des aretes                  .
  49 c . np2are . e   . nbarto . noeud milieux des aretes                   .
  50 c . cfaare . e   . nctfar*. codes des familles des aretes              .
  51 c .        .     . nbfare .   1 : famille MED                          .
  52 c .        .     .        .   2 : type de segment                      .
  53 c .        .     .        .   3 : orientation                          .
  54 c .        .     .        .   4 : famille d'orientation inverse        .
  55 c .        .     .        .   5 : numero de ligne de frontiere         .
  56 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
  57 c .        .     .        . <= 0 si non concernee                      .
  58 c .        .     .        .   6 : famille frontiere active/inactive    .
  59 c .        .     .        .   7 : numero de surface de frontiere       .
  60 c .        .     .        . + l : appartenance a l'equivalence l       .
  61 c . famare . e   . nbarto . famille des aretes                         .
  62 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  63 c . posifa . e   . nbarto . pointeur sur tableau facare                .
  64 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  65 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  66 c . filtri . e   . nbtrto . premier fils des triangles                 .
  67 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  68 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  69 c . filqua . e   . nbquto . premier fils des quadrangles               .
  70 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
  71 c .        .     . nbfqua .   1 : famille MED                          .
  72 c .        .     .        .   2 : type de quadrangle                   .
  73 c .        .     .        .   3 : numero de surface de frontiere       .
  74 c .        .     .        .   4 : famille des aretes internes apres raf.
  75 c .        .     .        .   5 : famille des triangles de conformite  .
  76 c .        .     .        .   6 : famille de sf active/inactive        .
  77 c .        .     .        . + l : appartenance a l'equivalence l       .
  78 c . famqua . e   . nbquto . famille des quadrangles                    .
  79 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  80 c . cotrte . e   .nbtecf*4. code des 4 triangles des tetraedres        .
  81 c . aretet . e   .nbteca*6. numeros des 6 aretes des tetraedres        .
  82 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  83 c . filtet . e   . nbteto . premier fils des tetraedres                .
  84 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  85 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  86 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
  87 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  88 c . filhex . e   . nbheto . premier fils des hexaedres                 .
  89 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  90 c . cofapy . e   .nbpycf*5. codes des faces des pyramides              .
  91 c . arepyr . e   .nbpyca*8. numeros des 8 aretes des pyramides         .
  92 c . hetpyr . e   . nbpyto . historique de l'etat des pyramides         .
  93 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  94 c . cofape . e   .nbpecf*5. code des 5 faces des pentaedres            .
  95 c . arepen . e   .nbpeca*9. numeros des 9 aretes des pentaedres        .
  96 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  97 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
  98 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
  99 c .        .     .        .   0 : pas de voisin                        .
 100 c .        .     .        . j>0 : tetraedre j                          .
 101 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
 102 c . pypetr . e   .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
 103 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
 104 c .        .     .        . pypetr(2,j) = numero du pentaedre voisin   .
 105 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
 106 c . volqua . e   .2*nbquto. numeros des 2 volumes par quadrangle       .
 107 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
 108 c .        .     .        .   0 : pas de voisin                        .
 109 c .        .     .        . j>0 : hexaedre j                           .
 110 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
 111 c . pypequ . e   .2*lgpype. pypequ(1,j) = numero de la pyramide voisine.
 112 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
 113 c .        .     .        . pypequ(2,j) = numero du pentaedre voisin   .
 114 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
 115 c . nbarfr . e   .   1    . nombre d'aretes concernees                 .
 116 c . arefro . e   . nbarfr . liste des aretes concernees                .
 117 c . nbqufr . e   .   1    . nombre de quadrangles concernes            .
 118 c . quafro . e   . nbqufr . liste des quadrangles concernes            .
 119 c . lgetco . e   .   1    . longueur du tableau de l'etat courant      .
 120 c . taetco . e   . lgetco . tableau de l'etat courant                  .
 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 = 'SFCOTL' )
 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 somare(2,nbarto), filare(nbarto), np2are(nbarto)
 163       integer posifa(0:nbarto), facare(nbfaar)
 164       integer cfaare(nctfar,nbfare), famare(nbarto)
 165       integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto)
 166       integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto)
 167       integer cfaqua(nctfqu,nbfqua), famqua(nbquto)
 168       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
 169       integer hettet(nbteto)
 170       integer filtet(nbteto)
 171       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
 172       integer hethex(nbheto)
 173       integer filhex(nbheto)
 174       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
 175       integer hetpyr(nbpyto)
 176       integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
 177       integer hetpen(nbpeto)
 178       integer voltri(2,nbtrto), pypetr(2,*)
 179       integer volqua(2,nbquto), pypequ(2,*)
 180       integer nbarfr, arefro(nbarfr)
 181       integer nbqufr, quafro(nbqufr)
 182 c
 183       double precision coonoe(nbnoto,sdim)
 184 c
 185       integer lgetco
 186       integer taetco(lgetco)
 187 c
 188       integer ulsort, langue, codret
 189 c
 190 c 0.4. ==> variables locales
 191 c
 192       integer nretap, nrsset
 193       integer iaux, jaux
 194 c
 195       integer nbcoa1, nbcoq1, nuphas
 196       integer nbcoa2, nbcoq2
 197       integer nbarf0, nbquf0
 198 c
 199       character*6 saux
 200 c
 201       integer nbmess
 202       parameter ( nbmess = 20 )
 203       character*80 texte(nblang,nbmess)
 204 c
 205 c 0.5. ==> initialisations
 206 c ______________________________________________________________________
 207 c
 208 c====
 209 c 1. messages
 210 c====
 211 c
 212       codret = 0
 213 c
 214 c 1.3. ==> les messages
 215 c
 216 #include "impr01.h"
 217 c
 218 #ifdef _DEBUG_HOMARD_
 219       write (ulsort,texte(langue,1)) 'Entree', nompro
 220       call dmflsh (iaux)
 221 #endif
 222 c
 223       texte(1,4) = '(/,a6,'' CONTROLES'')'
 224       texte(1,5) = '(16(''=''),/)'
 225       texte(1,6) = '(/,''Phase de controle'',i10,/,27(''-''))'
 226       texte(1,7) = '(/,''. Examen du '',a,i10)'
 227       texte(1,8) =
 228      >'(''==> Nombre de corrections de noeuds lies a des '',a,'':'',
 229      >i10)'
 230       texte(1,9) = '(''==> Tout va bien.'')'
 231       texte(1,10) = '(''Nombre de '',a,''concernes :'',i10)'
 232       texte(1,11) = '(''Nombre de '',a,'' a basculer :'',i10)'
 233       texte(1,12) = '(''... Reprise du '',a,i10)'
 234 c
 235       texte(2,4) = '(/,a6,'' CHECK'')'
 236       texte(2,5) = '(12(''=''),/)'
 237       texte(2,6) = '(/,''Checking phase #'',i10,/,26(''-''))'
 238       texte(2,7) = '(/,''. Examination of '',a,'' # '',i10)'
 239       texte(2,8) =
 240      >'(''==> Number of corrections of nodes connected to '',a,'':'',
 241      >i10)'
 242       texte(2,9) = '(''==> Everything is OK.'')'
 243       texte(2,10) = '(''Number of involved '',a,'':'',i10)'
 244       texte(2,11) = '(''Number of '',a,'' to swap :'',i10)'
 245       texte(2,12) = '(''... Correction of '',a,i10)'
 246 c
 247 cgn 1001 format(a,' :',i10,', ',3g13.5)
 248 c
 249 c 1.4. ==> le numero de sous-etape
 250 c
 251       nretap = taetco(1)
 252       nrsset = taetco(2) + 1
 253       taetco(2) = nrsset
 254 c
 255       call utcvne ( nretap, nrsset, saux, iaux, codret )
 256 c
 257 c 1.5. ==> le titre
 258 c
 259       write (ulsort,texte(langue,4)) saux
 260       write (ulsort,texte(langue,5))
 261 c
 262 c====
 263 c 2. Prealables
 264 c====
 265 c
 266       nuphas = 0
 267       nbarf0 = nbarfr
 268       nbquf0 = nbqufr
 269 cgn        if ( nbarfr.gt.0 ) return
 270 c
 271    20 continue
 272 c
 273 c====
 274 c 3. Controle des retournements pour les decoupages homogenes
 275 c====
 276 #ifdef _DEBUG_HOMARD_
 277       write (ulsort,*) '3. Retournements ; codret = ', codret
 278 #endif
 279 c
 280       if ( codret.eq.0 ) then
 281 c
 282       nuphas = nuphas + 1
 283       write (ulsort,texte(langue,6)) nuphas
 284 c
 285 #ifdef _DEBUG_HOMARD_
 286       write (ulsort,texte(langue,3)) 'SFCOT1', nompro
 287 #endif
 288       call sfcot1 ( nbcoq1, nbcoa1,
 289      >              coonoe,
 290      >              somare, filare, np2are,
 291      >              cfaare, famare,
 292      >              facare, posifa,
 293      >              hettri, aretri, filtri,
 294      >              hetqua, arequa, filqua,
 295      >              cfaqua, famqua,
 296      >              tritet, cotrte, aretet,
 297      >              hettet, filtet,
 298      >              quahex, coquhe, arehex,
 299      >              hethex, filhex,
 300      >              voltri, pypetr,
 301      >              volqua, pypequ,
 302      >              nbarf0, arefro,
 303      >              nbquf0, quafro,
 304      >              ulsort, langue, codret)
 305 c
 306       endif
 307 c
 308       if ( codret.eq.0 ) then
 309 c
 310       if ( (nbcoa1+nbcoq1).gt.0 ) then
 311 c
 312         if ( nbcoq1.gt.0 ) then
 313           write (ulsort,texte(langue,8)) mess14(langue,3,4), nbcoq1
 314         endif
 315 c
 316         if ( nbcoa1.gt.0 ) then
 317           write (ulsort,texte(langue,8)) mess14(langue,3,1), nbcoa1
 318         endif
 319 c
 320       else
 321 c
 322         write (ulsort,texte(langue,9))
 323 c
 324       endif
 325 c
 326       endif
 327 c
 328 c====
 329 c 4. Controle des interpenetrations
 330 c====
 331 #ifdef _DEBUG_HOMARD_
 332       write (ulsort,*) '4. Interpenetrations ; codret = ', codret
 333 #endif
 334 c
 335       nbcoa2 = 0
 336       nbcoq2 = 0
 337 c
 338 #ifdef _DEBUG_HOMARD_
 339       if ( codret.eq.0 ) then
 340 c
 341       nuphas = nuphas + 1
 342       write (ulsort,texte(langue,6)) nuphas
 343 c
 344 #ifdef _DEBUG_HOMARD_
 345       write (ulsort,texte(langue,3)) 'SFCOT2', nompro
 346 #endif
 347       call sfcot2 ( nbcoq2, nbcoa2,
 348      >              coonoe,
 349      >              somare, filare, np2are,
 350      >              cfaare, famare,
 351      >              facare, posifa,
 352      >              hettri, aretri, filtri,
 353      >              hetqua, arequa, filqua,
 354      >              cfaqua, famqua,
 355      >              tritet, cotrte, aretet, hettet,
 356      >              filtet,
 357      >              quahex, coquhe, arehex, hethex,
 358      >              filhex,
 359      >              facpyr, cofapy, arepyr, hetpyr,
 360      >              facpen, cofape, arepen, hetpen,
 361      >              voltri, pypetr,
 362      >              volqua, pypequ,
 363      >              nbarf0, arefro,
 364      >              nbquf0, quafro,
 365      >              ulsort, langue, codret)
 366 c
 367       endif
 368 c
 369 c
 370       if ( codret.eq.0 ) then
 371 c
 372       if ( (nbcoa2+nbcoq2).gt.0 ) then
 373 c
 374         if ( nbcoq2.gt.0 ) then
 375           write (ulsort,texte(langue,8)) mess14(langue,3,4), nbcoq2
 376         endif
 377 c
 378         if ( nbcoa2.gt.0 ) then
 379           write (ulsort,texte(langue,8)) mess14(langue,3,1), nbcoa2
 380         endif
 381 c
 382       else
 383 c
 384         write (ulsort,texte(langue,9))
 385 c
 386       endif
 387 c
 388       endif
 389 #endif
 390 c
 391 c====
 392 c 5. Tant qu'il y a eu une correction, on recommence les tests
 393 c====
 394 c
 395       if ( codret.eq.0 ) then
 396 c
 397       if ( (nbcoa1+nbcoq1+nbcoq2+nbcoa2).gt.0 ) then
 398 c
 399 c       On raccourcit les listes des quadrangles et aretes a controler
 400 c
 401         jaux = nbarf0
 402         nbarf0 = 0
 403         do 51 , iaux = 1 , jaux
 404           if ( arefro(iaux).gt.0 ) then
 405             nbarf0 = nbarf0 + 1
 406             arefro(nbarf0) = arefro(iaux)
 407           endif
 408    51   continue
 409 c
 410         jaux = nbquf0
 411         nbquf0 = 0
 412         do 52 , iaux = 1 , jaux
 413           if ( quafro(iaux).gt.0 ) then
 414             nbquf0 = nbquf0 + 1
 415             quafro(nbquf0) = quafro(iaux)
 416           endif
 417    52   continue
 418 c
 419         goto 20
 420 c
 421       endif
 422 c
 423       endif
 424 c
 425    59   continue
 426 c
 427 c====
 428 c 6. La fin
 429 c====
 430 c
 431       if ( codret.ne.0 ) then
 432 c
 433 #include "envex2.h"
 434 c
 435       write (ulsort,texte(langue,1)) 'Sortie', nompro
 436       write (ulsort,texte(langue,2)) codret
 437 c
 438       endif
 439 c
 440 #ifdef _DEBUG_HOMARD_
 441       write (ulsort,texte(langue,1)) 'Sortie', nompro
 442       call dmflsh (iaux)
 443 #endif
 444 c
 445       end