src/tool/Utilitaire/utnc11.F

   1       subroutine utnc11 ( nbanci, arreca,
   2      >                    aretri, filtri,
   3      >                    arequa, filqua,
   4      >                    filare, posifa, facare,
   5      >                    nbnoct, nbnocq,
   6      >                    ulsort, langue, codret )
   7 c ______________________________________________________________________
   8 c
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c
  27 c    UTilitaire - Non Conformite - phase 11
  28 c    --           -   -                  --
  29 c    On repere chaque face du macro maillage qui est bordee par une
  30 c    arete recouvrante pour la non conformite initiale.
  31 c    . Pour un triangle, on compte ceux dont les 3 aretes
  32 c      sont recouvrantes.
  33 c    . Pour un quadrangle on compte ceux dont les 4 aretes
  34 c      sont recouvrantes.
  35 c ______________________________________________________________________
  36 c .        .     .        .                                            .
  37 c .  nom   . e/s . taille .           description                      .
  38 c .____________________________________________________________________.
  39 c . nbanci . e   .    1   . nombre d'aretes de non conformite initiale .
  40 c .        .     .        . egal au nombre d'aretes recouvrant 2 autres.
  41 c . arreca . e   .2*nbanci. liste des aretes recouvrant une autre      .
  42 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  43 c . filtri . e   . nbtrto . premier fils des triangles                 .
  44 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  45 c . filqua . e   . nbquto . premier fils des quadrangles               .
  46 c . filare . e   . nbarto . premiere fille des aretes                  .
  47 c . posifa . e   . nbarto . pointeur sur tableau facare                .
  48 c . nbnoct .  s  .   1    . nombre de tria avec 3 aretes recouvrantes  .
  49 c . nbnocq .  s  .   1    . nombre de quad avec 4 aretes recouvrantes  .
  50 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  51 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  52 c . langue . e   .    1   . langue des messages                        .
  53 c .        .     .        . 1 : francais, 2 : anglais                  .
  54 c . codret . es  .    1   . code de retour des modules                 .
  55 c .        .     .        . 0 : pas de probleme                        .
  56 c .        .     .        . 3 : probleme                               .
  57 c ______________________________________________________________________
  58 c
  59 c====
  60 c 0. declarations et dimensionnement
  61 c====
  62 c
  63 c 0.1. ==> generalites
  64 c
  65       implicit none
  66       save
  67 c
  68       character*6 nompro
  69       parameter ( nompro = 'UTNC11' )
  70 c
  71 #include "nblang.h"
  72 c
  73 c 0.2. ==> communs
  74 c
  75 #include "envex1.h"
  76 #include "impr02.h"
  77 #include "nombar.h"
  78 #include "nombtr.h"
  79 #include "nombqu.h"
  80 c
  81 c 0.3. ==> arguments
  82 c
  83       integer nbanci, arreca(2*nbanci)
  84       integer aretri(nbtrto,3)
  85       integer filtri(nbtrto)
  86       integer arequa(nbquto,4)
  87       integer filqua(nbquto)
  88       integer filare(nbarto)
  89       integer posifa(0:nbarto), facare(nbfaar)
  90       integer nbnoct, nbnocq
  91 c
  92       integer ulsort, langue, codret
  93 c
  94 c 0.4. ==> variables locales
  95 c
  96       integer iaux, jaux, kaux
  97       integer ipos
  98       integer ideb, ifin
  99       integer larete, letria, lequad
 100       integer compte
 101 c
 102       integer nbmess
 103       parameter ( nbmess = 10 )
 104       character*80 texte(nblang,nbmess)
 105 c
 106 c 0.5. ==> initialisations
 107 c ______________________________________________________________________
 108 c
 109 c====
 110 c 1. preliminaires
 111 c====
 112 c
 113 c 1.1. ==> messages
 114 c
 115 #include "impr01.h"
 116 c
 117 #ifdef _DEBUG_HOMARD_
 118       write (ulsort,texte(langue,1)) 'Entree', nompro
 119       call dmflsh (iaux)
 120 #endif
 121 c
 122       texte(1,4) =
 123      > '(''Nombre de paires de '',a,'' non-conformes :'',i10))'
 124       texte(1,5) = '(a,'' Examen du '',a,'' numero'',i10)'
 125       texte(1,6) = '(''...'',i2,''eme face voisine'')'
 126       texte(1,7) = '(''... Nombre de '',a,'' recouvrants :'',i10))'
 127       texte(1,8) =
 128      > '(''Nombre de '',a,'' a aretes recouvrantes :'',i10))'
 129 c
 130       texte(2,4) =
 131      > '(''Number of pairs of non-conformal '',a,'' :'',i10))'
 132       texte(2,5) = '(a,'' Examination of '',a,'' #'',i10)'
 133       texte(2,6) = '(''...'',i2,''th face'')'
 134       texte(2,7) = '(''Number of covering '',a,'' :'',i10))'
 135       texte(2,8) =
 136      > '(''Number of '',a,'' with covering edges :'',i10))'
 137 c
 138       codret = 0
 139 c
 140       nbnoct = 0
 141       nbnocq = 0
 142 c
 143 #ifdef _DEBUG_HOMARD_
 144       write (ulsort,texte(langue,4)) mess14(langue,3,1), nbanci
 145 #endif
 146 c
 147 c====
 148 c 2. On regarde toutes les aretes qui en recouvrent une autre.
 149 c====
 150 cgn       print *,'filqua : ',filqua
 151 c
 152       jaux = 2*nbanci
 153       do 21 , iaux = 1 , jaux
 154 c
 155         larete = arreca(iaux)
 156 #ifdef _DEBUG_HOMARD_
 157       write (ulsort,texte(langue,5)) '.', mess14(langue,1,1), larete
 158 #endif
 159 c
 160 c 2.1. ==> On regarde toutes les faces qui s'appuie sur cette arete
 161 c
 162         ideb = posifa(larete-1)+1
 163         ifin = posifa(larete)
 164 c
 165         do 211 , ipos = ideb, ifin
 166 #ifdef _DEBUG_HOMARD_
 167       write (ulsort,texte(langue,6)) ipos-ideb+1
 168 #endif
 169 c
 170 c 2.1.1. ==> un triangle : on arrete pour le moment
 171 c
 172           if ( facare(ipos).gt.0 ) then
 173             letria = facare(ipos)
 174 cgn#ifdef _DEBUG_HOMARD_
 175       write (ulsort,texte(langue,5)) '...', mess14(langue,1,2), letria
 176 cgn#endif
 177             codret = 666
 178 c
 179 c 2.1.2. ==> Un quadrangle : on compte le nombre d'aretes recouvrantes
 180 c            qui le definissent
 181 c            Attention a ne pas examiner plusieurs fois de suite
 182 c            le meme quadrangle ...
 183 c
 184           else
 185             lequad = -facare(ipos)
 186 #ifdef _DEBUG_HOMARD_
 187       write (ulsort,texte(langue,5)) '...', mess14(langue,1,4), lequad
 188 #endif
 189             if ( filqua(lequad).eq.0 ) then
 190 c
 191               compte = 0
 192               do 2121 , kaux = 1 , 4
 193                 if ( filare(arequa(lequad,kaux)).ne.0 ) then
 194                   compte = compte + 1
 195                 endif
 196  2121         continue
 197 #ifdef _DEBUG_HOMARD_
 198       write (ulsort,texte(langue,7)) mess14(langue,3,1), compte
 199 #endif
 200 c
 201               if ( compte.eq.4 ) then
 202                 filqua(lequad) = -4
 203                 nbnocq = nbnocq + 1
 204               endif
 205 c
 206             endif
 207 c
 208           endif
 209 c
 210   211   continue
 211 c
 212    21 continue
 213 c
 214 #ifdef _DEBUG_HOMARD_
 215       write (ulsort,texte(langue,8)) mess14(langue,3,2), nbnoct
 216       write (ulsort,texte(langue,8)) mess14(langue,3,4), nbnocq
 217 #endif
 218 cgn       print *,'filqua : ',filqua
 219 c
 220 c====
 221 c 3. la fin
 222 c====
 223 c
 224       if ( codret.ne.0 ) then
 225 c
 226 #include "envex2.h"
 227 c
 228       write (ulsort,texte(langue,1)) 'Sortie', nompro
 229       write (ulsort,texte(langue,2)) codret
 230 c
 231       endif
 232 c
 233 #ifdef _DEBUG_HOMARD_
 234       write (ulsort,texte(langue,1)) 'Sortie', nompro
 235       call dmflsh (iaux)
 236 #endif
 237 c
 238       end