src/tool/Utilitaire/utb17c.F

   1       subroutine utb17c ( somare, np2are,
   2      >                    hettri, aretri,
   3      >                    hetqua, arequa,
   4      >                    voltri,
   5      >                    volqua,
   6      >                    posifa, facare,
   7      >                    famare, cfaare,
   8      >                    famtri, cfatri,
   9      >                    famqua, cfaqua,
  10      >                    tabaux,
  11      >                    ulbila,
  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    UTilitaire - Bilan sur le maillage - option 17 - phase c
  34 c    --           -                              --         -
  35 c ______________________________________________________________________
  36 c
  37 c Diagnostic des elements surfaciques du calcul
  38 c ______________________________________________________________________
  39 c .        .     .        .                                            .
  40 c .  nom   . e/s . taille .           description                      .
  41 c .____________________________________________________________________.
  42 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  43 c . np2are . e   . nbarto . numero des noeuds p2 milieux d'aretes      .
  44 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  45 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  46 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  47 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  48 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
  49 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
  50 c .        .     .        .   0 : pas de voisin                        .
  51 c .        .     .        . j>0 : tetraedre j                          .
  52 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
  53 c . volqua . e   .2*nbquto. numeros des 2 volumes par quadrangle       .
  54 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
  55 c .        .     .        .   0 : pas de voisin                        .
  56 c .        .     .        . j>0 : hexaedre j                           .
  57 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
  58 c . posifa . e   .0:nbarto. pointeur sur tableau facare                .
  59 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  60 c . famare . e   . nbarto . famille des aretes                         .
  61 c . cfaare . e   . nctfar*. codes des familles des aretes              .
  62 c .        .     . nbfare .   1 : famille MED                          .
  63 c .        .     .        .   2 : type de segment                      .
  64 c .        .     .        .   3 : orientation                          .
  65 c .        .     .        .   4 : famille d'orientation inverse        .
  66 c .        .     .        .   5 : numero de ligne de frontiere         .
  67 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
  68 c .        .     .        . <= 0 si non concernee                      .
  69 c .        .     .        .   6 : famille frontiere active/inactive    .
  70 c .        .     .        .   7 : numero de surface de frontiere       .
  71 c .        .     .        . + l : appartenance a l'equivalence l       .
  72 c . famtri . e   . nbtrto . famille des triangles                      .
  73 c . cfatri . e   . nctftr*. codes des familles des triangles           .
  74 c .        .     . nbftri .   1 : famille MED                          .
  75 c .        .     .        .   2 : type de triangle                     .
  76 c .        .     .        .   3 : numero de surface de frontiere       .
  77 c .        .     .        .   4 : famille des aretes internes apres raf.
  78 c .        .     .        . + l : appartenance a l'equivalence l       .
  79 c . famqua . e   . nbquto . famille des quadrangles                    .
  80 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
  81 c .        .     . nbfqua .   1 : famille MED                          .
  82 c .        .     .        .   2 : type de quadrangle                   .
  83 c .        .     .        .   3 : numero de surface de frontiere       .
  84 c .        .     .        .   4 : famille des aretes internes apres raf.
  85 c .        .     .        .   5 : famille des triangles de conformite  .
  86 c .        .     .        .   6 : famille de sf active/inactive        .
  87 c .        .     .        . + l : appartenance a l'equivalence l       .
  88 c . tabaux . e   . nbnoto . 0 : le noeud est interne                   .
  89 c .        .     .        . 1 : le noeud est au bord d'une face        .
  90 c . ulbila . e   .   1    . unite logique d'ecriture du bilan          .
  91 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  92 c . langue . e   .    1   . langue des messages                        .
  93 c .        .     .        . 1 : francais, 2 : anglais                  .
  94 c . codret .  s  .    1   . code de retour des modules                 .
  95 c .        .     .        . 0 : pas de probleme                        .
  96 c .        .     .        . 1 : probleme                               .
  97 c .____________________________________________________________________.
  98 c
  99 c====
 100 c 0. declarations et dimensionnement
 101 c====
 102 c
 103 c 0.1. ==> generalites
 104 c
 105       implicit none
 106       save
 107 c
 108       character*6 nompro
 109       parameter ( nompro = 'UTB17C' )
 110 c
 111 #include "nblang.h"
 112 #include "coftex.h"
 113 c
 114 c 0.2. ==> communs
 115 c
 116 #include "envca1.h"
 117 #include "nbfami.h"
 118 #include "nombno.h"
 119 #include "nombar.h"
 120 #include "nombtr.h"
 121 #include "nombqu.h"
 122 #include "nombte.h"
 123 #include "nombhe.h"
 124 #include "nombpy.h"
 125 #include "nombpe.h"
 126 c
 127 #include "dicfen.h"
 128 #include "impr02.h"
 129 c
 130 c 0.3. ==> arguments
 131 c
 132       integer somare(2,nbarto), np2are(nbarto)
 133       integer hettri(nbtrto), aretri(nbtrto,3)
 134       integer hetqua(nbquto), arequa(nbquto,4)
 135 c
 136       integer voltri(2,nbtrto)
 137       integer volqua(2,nbquto)
 138       integer posifa(0:nbarto), facare(nbfaar)
 139 c
 140       integer famare(nbarto), cfaare(nctfar,nbfare)
 141       integer famtri(nbtrto), cfatri(nctftr,nbftri)
 142       integer famqua(nbquto), cfaqua(nctfqu,nbfqua)
 143 c
 144       integer tabaux(nbnoto)
 145 c
 146       integer ulbila
 147       integer ulsort, langue, codret
 148 c
 149 c 0.4. ==> variables locales
 150 c
 151       integer iaux, jaux, kaux
 152       integer jdeb, jfin
 153       integer letria, lequad, larete
 154       integer laface
 155       integer nbensc, nbensb
 156       integer nbvoto
 157       integer etat, etat00
 158       integer a1, a2, a3, a4
 159       integer sa1a2, sa2a3, sa3a1, sa3a4, sa4a1
 160       integer listso(4)
 161 c
 162       logical afaire
 163       logical aubord
 164 c
 165       integer nbmess
 166       parameter (nbmess = 10 )
 167       character*80 texte(nblang,nbmess)
 168 c
 169 c 0.5. ==> initialisations
 170 c ______________________________________________________________________
 171 c
 172 c====
 173 c 1. messages
 174 c====
 175 c
 176 #include "impr01.h"
 177 c
 178 #ifdef _DEBUG_HOMARD_
 179       write (ulsort,texte(langue,1)) 'Entree', nompro
 180       call dmflsh (iaux)
 181 #endif
 182 c
 183       texte(1,4) = '(''Nombre de '',a,'' actifs :'',i10)'
 184       texte(1,5) = '(''. Examen du '',a,i10)'
 185       texte(1,6) = '(''... '',a,i10,'' au bord'')'
 186       texte(1,7) =
 187      >'(''. Le bord du '',a,i10,'' n''''est pas une maille de calcul.''
 188      >)'
 189       texte(1,8) = '(''. Le '',a,i8,'' est surcontraint.'')'
 190 c
 191       texte(2,4) = '(''Number of active '',a,'' : '',i8)'
 192       texte(2,5) = '(''. Examination of '',a,''#'',i8)'
 193       texte(2,6) = '(''... '',a,''#'',i8,'' on the boundary'')'
 194       texte(2,7) =
 195      >'(''. The boundary of the '',a,i10,'' is not a calculation mesh.''
 196      >)'
 197       texte(2,8) = '(''. The '',a,''#'',i8,'' is overstressed.'')'
 198 c
 199 #ifdef _DEBUG_HOMARD_
 200       write (ulsort,texte(langue,4)) mess14(langue,3,2), nbtrac
 201       write (ulsort,texte(langue,4)) mess14(langue,3,4), nbquac
 202 #endif
 203 c
 204       codret = 0
 205 c
 206 c====
 207 c 2. Diagnostic sur les triangles
 208 c====
 209 #ifdef _DEBUG_HOMARD_
 210       write (ulsort,*) '2. triangles, codret = ', codret
 211 #endif
 212 c
 213       if ( nbtrac.gt.0 ) then
 214 c
 215         nbensc = 0
 216         nbensb = 0
 217         aubord = .false.
 218         afaire = .false.
 219         nbvoto = nbteto + nbpyto + nbpeto
 220 c
 221         do 2 , letria = 1, nbtrto
 222 c
 223 #ifdef _DEBUG_HOMARD_
 224       write (ulsort,texte(langue,5)) mess14(langue,1,2), letria
 225 #endif
 226 c
 227           if ( cfatri(cotyel,famtri(letria)).ne.0 ) then
 228 c
 229           etat = mod( hettri(letria),10 )
 230 c
 231           if ( etat.eq.0 ) then
 232 c
 233 c 2.0. ==> S'il y a des volumes, on ne prend que des triangles purs
 234 c
 235             if ( nbvoto.ne.0 ) then
 236 c
 237               if ( voltri(1,letria).ne.0 ) then
 238                 goto 2
 239               endif
 240 c
 241             endif
 242 c
 243             afaire = .true.
 244 c
 245 c 2.1. ==> On regarde si tous les noeuds sont sur le bord
 246 c
 247             a1 = aretri(letria,1)
 248             a2 = aretri(letria,2)
 249             a3 = aretri(letria,3)
 250             call utsotr ( somare, a1, a2, a3,
 251      >                    sa1a2, sa2a3, sa3a1 )
 252 c
 253             listso(1) = sa1a2
 254             listso(2) = sa2a3
 255             listso(3) = sa3a1
 256 c
 257             do 211 , iaux = 1 , 3
 258               if ( tabaux(listso(iaux)).eq.0 ) then
 259                 goto 219
 260               endif
 261   211       continue
 262             if ( degre.eq.2 ) then
 263               do 212 , iaux = 1 , 3
 264                 if ( tabaux(np2are(aretri(letria,iaux))).eq.0 ) then
 265                   goto 219
 266                 endif
 267   212         continue
 268             endif
 269 c
 270             nbensc = nbensc + 1
 271 #ifdef _DEBUG_HOMARD_
 272             write (ulsort,texte(langue,8)) mess14(langue,1,2), letria
 273 #endif
 274 c
 275   219       continue
 276 c
 277 c 2.2. ==> On verifie que chaque arete au bord est un element de calcul
 278 c
 279             do 22 , iaux = 1 , 3
 280 c
 281               larete = aretri(letria,iaux)
 282               jdeb = posifa(larete-1)+1
 283               jfin = posifa(larete)
 284 c
 285 c 2.2.1. ==> L'arete a au plus une face voisine : elle est de bord
 286 c
 287               if ( jfin.le.jdeb ) then
 288 cgn         write (ulsort,*) 'au plus une face voisine'
 289 c
 290                 kaux = 0
 291 c
 292 c 2.2.2. ==> L'arete a au moins deux faces voisines : il faut compter
 293 c            le nombre de faces actives car avec la conformite, une
 294 c            face et sa fille sont declarees voisines de l'arete
 295 c
 296               else
 297 c
 298                 kaux = 0
 299                 do 222 , jaux = jdeb, jfin
 300                   laface = facare(jaux)
 301 cgn         write (ulsort,*) 'voisine de', laface
 302                   if ( laface.gt.0 ) then
 303                     etat00 = mod(hettri(laface),10)
 304                   else
 305                     etat00 = mod(hetqua(-laface),100)
 306                   endif
 307                   if ( etat00.eq.0 ) then
 308                     kaux = kaux + 1
 309                   endif
 310   222           continue
 311 c
 312               endif
 313 c
 314 c 2.2.3. ==> Bilan
 315 c
 316               if ( kaux.le.1 ) then
 317 #ifdef _DEBUG_HOMARD_
 318               write (ulsort,texte(langue,6)) mess14(langue,1,1), larete
 319 #endif
 320                 aubord = .true.
 321 c
 322                 if ( cfaare(cotyel,famare(larete)).eq.0 ) then
 323                   nbensb = nbensb + 1
 324 #ifdef _DEBUG_HOMARD_
 325               write (ulsort,texte(langue,7)) mess14(langue,1,2), letria
 326 #endif
 327                   goto 229
 328                 endif
 329 c
 330               endif
 331 c
 332    22       continue
 333 c
 334   229       continue
 335 c
 336           endif
 337 c
 338           endif
 339 c
 340     2   continue
 341 c
 342 c 2.3. ==> Impression
 343 c
 344         if ( afaire ) then
 345 c
 346 #ifdef _DEBUG_HOMARD_
 347       write (ulsort,texte(langue,3)) 'UTB17E', nompro
 348 #endif
 349           iaux = 2
 350           call utb17e ( iaux, nbensc, aubord, nbensb,
 351      >                  ulbila,
 352      >                  ulsort, langue, codret )
 353 c
 354         endif
 355 c
 356       endif
 357 c
 358 c====
 359 c 3. Diagnostic sur les quadrangles
 360 c====
 361 #ifdef _DEBUG_HOMARD_
 362       write (ulsort,*) '3. quadrangles, codret = ', codret
 363 #endif
 364 c
 365       if ( nbquac.gt.0 ) then
 366 c
 367         nbensc = 0
 368         nbensb = 0
 369         aubord = .false.
 370         afaire = .false.
 371         nbvoto = nbheto + nbpyto + nbpeto
 372 c
 373         do 3 , lequad = 1, nbquto
 374 c
 375 #ifdef _DEBUG_HOMARD_
 376       write (ulsort,texte(langue,5)) mess14(langue,1,4), lequad
 377 #endif
 378 c
 379           if ( cfaqua(cotyel,famqua(lequad)).ne.0 ) then
 380 c
 381           etat = mod( hetqua(lequad),100 )
 382 c
 383           if ( etat.eq.0 ) then
 384 c
 385 c 3.0. ==> S'il y a des volumes, on ne prend que des quadrangles purs
 386 c
 387             if ( nbvoto.ne.0 ) then
 388 c
 389               if ( volqua(1,lequad).ne.0 ) then
 390                 goto 3
 391               endif
 392 c
 393             endif
 394 c
 395             afaire = .true.
 396 c
 397 c 3.1. ==> On regarde si tous les noeuds sont sur le bord
 398 c
 399             a1 = arequa(lequad,1)
 400             a2 = arequa(lequad,2)
 401             a3 = arequa(lequad,3)
 402             a4 = arequa(lequad,4)
 403             call utsoqu ( somare, a1, a2, a3, a4,
 404      >                    sa1a2, sa2a3, sa3a4, sa4a1 )
 405             listso(1) = sa1a2
 406             listso(2) = sa2a3
 407             listso(3) = sa3a4
 408             listso(4) = sa4a1
 409 c
 410             do 311 , iaux = 1 , 4
 411               if ( tabaux(listso(iaux)).eq.0 ) then
 412                 goto 319
 413               endif
 414   311       continue
 415             if ( degre.eq.2 ) then
 416               do 312 , iaux = 1 , 4
 417                 if ( tabaux(np2are(arequa(lequad,iaux))).eq.0 ) then
 418                   goto 319
 419                 endif
 420   312         continue
 421             endif
 422 c
 423             nbensc = nbensc + 1
 424 #ifdef _DEBUG_HOMARD_
 425             write (ulsort,texte(langue,8)) mess14(langue,1,4), lequad
 426 #endif
 427 c
 428   319       continue
 429 c
 430 c 3.2. ==> On verifie que chaque arete au bord est un element de calcul
 431 c
 432             do 32 , iaux = 1 , 4
 433 c
 434               larete = arequa(lequad,iaux)
 435               jdeb = posifa(larete-1)+1
 436               jfin = posifa(larete)
 437 c
 438 c 3.2.1. ==> L'arete a au plus une face voisine : elle est de bord
 439 c
 440               if ( jfin.le.jdeb ) then
 441 cgn         write (ulsort,*) 'au plus une face voisine'
 442 c
 443                 kaux = 0
 444 c
 445 c 3.2.2. ==> L'arete a au moins deux faces voisines : il faut compter
 446 c            le nombre de faces actives car avec la conformite, une
 447 c            face et sa fille sont declarees voisines de l'arete
 448 c
 449               else
 450 c
 451                 kaux = 0
 452                 do 322 , jaux = jdeb, jfin
 453                   laface = facare(jaux)
 454 cgn         write (ulsort,*) 'voisine de', laface
 455                   if ( laface.gt.0 ) then
 456                     etat00 = mod(hettri(laface),10)
 457                   else
 458                     etat00 = mod(hetqua(-laface),100)
 459                   endif
 460                   if ( etat00.eq.0 ) then
 461                     kaux = kaux + 1
 462                   endif
 463   322           continue
 464 c
 465               endif
 466 c
 467 c 3.2.3. ==> Bilan
 468 c
 469               if ( kaux.le.1 ) then
 470 #ifdef _DEBUG_HOMARD_
 471               write (ulsort,texte(langue,6)) mess14(langue,1,1), larete
 472 #endif
 473                 aubord = .true.
 474 c
 475                 if ( cfaare(cotyel,famare(larete)).eq.0 ) then
 476                   nbensb = nbensb + 1
 477 #ifdef _DEBUG_HOMARD_
 478               write (ulsort,texte(langue,7)) mess14(langue,1,4), lequad
 479 #endif
 480                   goto 329
 481                 endif
 482 c
 483               endif
 484 c
 485    32       continue
 486 c
 487   329       continue
 488 c
 489           endif
 490 c
 491           endif
 492 c
 493     3   continue
 494 c
 495 c 3.3. ==> Impression
 496 c
 497         if ( afaire ) then
 498 c
 499 #ifdef _DEBUG_HOMARD_
 500       write (ulsort,texte(langue,3)) 'UTB17E', nompro
 501 #endif
 502           iaux = 4
 503           call utb17e ( iaux, nbensc, aubord, nbensb,
 504      >                  ulbila,
 505      >                  ulsort, langue, codret )
 506 c
 507         endif
 508 c
 509       endif
 510 c
 511       end