src/tool/Utilitaire/utnc09.F

   1       subroutine utnc09 ( nbanci, arrecb, numea0,
   2      >                    pertri, perqua, numead,
   3      >                    posifa, facare,
   4      >                    ulsort, langue, codret )
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c    UTilitaire - Non Conformite - phase 09
  26 c    --           -   -                  --
  27 c    On repere chaque face du macro maillage qui est bordee par une
  28 c    arete de non conformite initiale. On declare que cette face a une
  29 c    mere, dont le numero est un numero fictif, ne correspondant a
  30 c    aucune face possible.
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . nbanci . e   .    1   . nombre d'aretes de non conformite initiale .
  36 c .        .     .        . egal au nombre d'aretes recouvrant 2 autres.
  37 c . arrecb . e   .2*nbanci. liste des aretes recouvertes par une autre .
  38 c . numea0 . e   .   1    . ancien numero de la mere adoptive ou 0     .
  39 c . pertri . es  . nbtrto . pere des triangles                         .
  40 c . perqua . es  . nbquto . pere des quadrangles                       .
  41 c . numead .  s  .   1    . numero de la mere adoptive                 .
  42 c . posifa . e   . nbarto . pointeur sur tableau facare                .
  43 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  44 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  45 c . langue . e   .    1   . langue des messages                        .
  46 c .        .     .        . 1 : francais, 2 : anglais                  .
  47 c . codret . es  .    1   . code de retour des modules                 .
  48 c .        .     .        . 0 : pas de probleme                        .
  49 c .        .     .        . 3 : probleme                               .
  50 c ______________________________________________________________________
  51 c
  52 c====
  53 c 0. declarations et dimensionnement
  54 c====
  55 c
  56 c 0.1. ==> generalites
  57 c
  58       implicit none
  59       save
  60 c
  61       character*6 nompro
  62       parameter ( nompro = 'UTNC09' )
  63 c
  64 #include "nblang.h"
  65 c
  66 c 0.2. ==> communs
  67 c
  68 #include "envex1.h"
  69 c
  70 #include "nombar.h"
  71 #include "nombtr.h"
  72 #include "nombqu.h"
  73 c
  74 c 0.3. ==> arguments
  75 c
  76       integer nbanci, arrecb(2*nbanci)
  77       integer numea0
  78       integer pertri(nbtrto), perqua(nbquto)
  79       integer numead
  80       integer posifa(0:nbarto), facare(nbfaar)
  81 c
  82       integer ulsort, langue, codret
  83 c
  84 c 0.4. ==> variables locales
  85 c
  86       integer iaux, jaux
  87       integer ipos
  88       integer ideb, ifin
  89       integer larete
  90 c
  91       integer nbmess
  92       parameter ( nbmess = 10 )
  93       character*80 texte(nblang,nbmess)
  94 c
  95 c 0.5. ==> initialisations
  96 c ______________________________________________________________________
  97 c
  98 c====
  99 c 1. preliminaires
 100 c====
 101 c
 102 c 1.1. ==> messages
 103 c
 104 #include "impr01.h"
 105 c
 106 #ifdef _DEBUG_HOMARD_
 107       write (ulsort,texte(langue,1)) 'Entree', nompro
 108       call dmflsh (iaux)
 109 #endif
 110 c
 111       texte(1,4) = '(''Nombre de non-conformites :'',i10))'
 112       texte(1,5) = '(''Numero de la mere adoptive :'',i10))'
 113       texte(1,6) = '(''Examen de l''''arete'',i10)'
 114       texte(1,7) = '(''..'',i2,''eme face :'',i10)'
 115       texte(1,8) = '(''Ancien numero de la mere adoptive :'',i10))'
 116 c
 117       texte(2,4) = '(''Number of non-conformal situations :'',i10))'
 118       texte(2,5) = '(''Number for adoptive mother :'',i10))'
 119       texte(2,6) = '(''Examination of edge #'',i10)'
 120       texte(2,7) = '(''..'',i2,''th face :'',i10)'
 121       texte(2,8) = '(''Old number for adoptive mother :'',i10))'
 122 c
 123       codret = 0
 124 c
 125 #ifdef _DEBUG_HOMARD_
 126       write (ulsort,texte(langue,4)) nbanci
 127       if ( numea0.ne.0 ) then
 128         write (ulsort,texte(langue,8)) numea0
 129       endif
 130 #endif
 131 c
 132 c====
 133 c 2. On regarde toutes les aretes qui sont recouvertes par une autre.
 134 c    On trie les faces qui sont bordees par une de ces aretes.
 135 c    Chacune de ces faces qui sont du macro-maillage se voit
 136 c    attribuer une mere fictive, -nbfato-1, sauf si elle a deja une
 137 c    mere. Cela arrive dans le cas de face des recollement en 3D.
 138 c====
 139 cgn       print *,'perqua : ',perqua
 140 cgn       print *,'arrecb : ',arrecb
 141 c
 142       numead = -(nbtrto+nbquto+1)
 143 #ifdef _DEBUG_HOMARD_
 144       write (ulsort,texte(langue,5)) numead
 145 #endif
 146 c
 147       jaux = 2*nbanci
 148       do 21 , iaux = 1 , jaux
 149 c
 150         larete = arrecb(iaux)
 151 c
 152 #ifdef _DEBUG_HOMARD_
 153       write (ulsort,texte(langue,6)) larete
 154 #endif
 155         ideb = posifa(larete-1)+1
 156         ifin = posifa(larete)
 157         do 211 , ipos = ideb, ifin
 158 #ifdef _DEBUG_HOMARD_
 159       write (ulsort,texte(langue,7)) ipos-ideb+1, facare(ipos)
 160 #endif
 161           if ( facare(ipos).gt.0 ) then
 162             if ( facare(ipos).le.nbtrma ) then
 163               if ( pertri(facare(ipos)).eq.0 .or.
 164      >             pertri(facare(ipos)).eq.numea0 ) then
 165                 pertri(facare(ipos)) = numead
 166               endif
 167             endif
 168           else
 169             if ( -facare(ipos).le.nbquma ) then
 170               if ( perqua(-facare(ipos)).eq.0 .or.
 171      >             perqua(-facare(ipos)).eq.numea0 ) then
 172                 perqua(-facare(ipos)) = numead
 173               endif
 174             endif
 175           endif
 176   211   continue
 177 c
 178    21 continue
 179 cgn       print *,'pertri : ',pertri
 180 cgn       print *,'perqua : ',perqua
 181 c
 182 c====
 183 c 3. la fin
 184 c====
 185 c
 186       if ( codret.ne.0 ) then
 187 c
 188 #include "envex2.h"
 189 c
 190       write (ulsort,texte(langue,1)) 'Sortie', nompro
 191       write (ulsort,texte(langue,2)) codret
 192 c
 193       endif
 194 c
 195 #ifdef _DEBUG_HOMARD_
 196       write (ulsort,texte(langue,1)) 'Sortie', nompro
 197       call dmflsh (iaux)
 198 #endif
 199 c
 200       end