src/tool/Utilitaire/utnc07.F

   1       subroutine utnc07 ( nbanci,
   2      >                    noerec, arreca, arrecb,
   3      >                    somare, arenoe,
   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 07
  26 c    --           -   -                  --
  27 c    A partir des correspondances entre aretes, on memorise le sommet
  28 c    commun aux deux filles.
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . nbanci . e   .    1   . nombre d'aretes de non conformite initiale .
  34 c .        .     .        . egal au nombre d'aretes recouvrant 2 autres.
  35 c . noerec .  s  . nbanci . liste initiale des noeuds de recollement   .
  36 c . arreca . e   .2*nbanci. liste des aretes recouvrant une autre      .
  37 c . arrecb . e   .2*nbanci. liste des aretes recouvertes par une autre .
  38 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  39 c . arenoe . es  . nbnoto . 0 pour un sommet, le numero de l'arete pour.
  40 c .        .     .        . un noeud milieu                            .
  41 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  42 c . langue . e   .    1   . langue des messages                        .
  43 c .        .     .        . 1 : francais, 2 : anglais                  .
  44 c . codret . es  .    1   . code de retour des modules                 .
  45 c .        .     .        . 0 : pas de probleme                        .
  46 c .        .     .        . 3 : probleme                               .
  47 c ______________________________________________________________________
  48 c
  49 c====
  50 c 0. declarations et dimensionnement
  51 c====
  52 c
  53 c 0.1. ==> generalites
  54 c
  55       implicit none
  56       save
  57 c
  58       character*6 nompro
  59       parameter ( nompro = 'UTNC07' )
  60 c
  61 #include "nblang.h"
  62 c
  63 c 0.2. ==> communs
  64 c
  65 #include "envex1.h"
  66 c
  67 #include "nombno.h"
  68 #include "nombar.h"
  69 c
  70 c 0.3. ==> arguments
  71 c
  72       integer nbanci
  73       integer noerec(nbanci)
  74       integer arreca(2*nbanci), arrecb(2*nbanci)
  75       integer arenoe(nbnoto)
  76       integer somare(2,nbarto)
  77 c
  78       integer ulsort, langue, codret
  79 c
  80 c 0.4. ==> variables locales
  81 c
  82       integer iaux, jaux
  83       integer ifin, jfin
  84       integer laret1, laretg
  85       integer lesomm
  86 c
  87       integer nbmess
  88       parameter ( nbmess = 10 )
  89       character*80 texte(nblang,nbmess)
  90 c
  91 c 0.5. ==> initialisations
  92 c ______________________________________________________________________
  93 c
  94 c====
  95 c 1. preliminaires
  96 c====
  97 c
  98 c 1.1. ==> messages
  99 c
 100 #include "impr01.h"
 101 c
 102 #ifdef _DEBUG_HOMARD_
 103       write (ulsort,texte(langue,1)) 'Entree', nompro
 104       call dmflsh (iaux)
 105 #endif
 106 c
 107       texte(1,4) = '(''Examen de l''''arete'',i10)'
 108       texte(1,5) = '(''.. couverte par l''''arete'',i10)'
 109       texte(1,6) = '(''Sommet commun aux aretes'')'
 110       texte(1,7) = '(''Nombre de noeuds trouves  :'',i10)'
 111       texte(1,8) = '(''Nombre de noeuds attendus :'',i10)'
 112 c
 113       texte(2,4) = '(''Examination of edge #'',i10)'
 114       texte(2,5) = '(''.. covered by edge #'',i10)'
 115       texte(2,6) = '(''Glue for edges'')'
 116       texte(2,7) = '(''Number of found edges    :'',i10)'
 117       texte(2,8) = '(''Number of expected edges :'',i10)'
 118 c
 119       codret = 0
 120 c
 121 c====
 122 c 2. On regarde toutes les non conformites
 123 c====
 124 c
 125       jfin = 0
 126       ifin = 2*nbanci
 127       do 21 , iaux = 1 , ifin
 128 c
 129         if ( codret.eq.0 ) then
 130 c
 131         laret1 = arrecb(iaux)
 132         laretg = arreca(iaux)
 133 c
 134 #ifdef _DEBUG_HOMARD_
 135       write (ulsort,texte(langue,4)) laret1
 136       write (ulsort,texte(langue,5)) laretg
 137 #endif
 138 c
 139         lesomm = somare(2,laret1)
 140 c
 141         do 211 , jaux = 1 , jfin
 142 c
 143            if ( noerec(jaux).eq.lesomm ) then
 144              goto 21
 145            endif
 146 c
 147   211   continue
 148 c
 149         jfin = jfin + 1
 150         noerec(jfin) = lesomm
 151         arenoe(lesomm) = laretg
 152 c
 153         endif
 154 c
 155    21 continue
 156 c
 157 c====
 158 c 3. controle
 159 c====
 160 c
 161       if ( jfin.gt.nbanci ) then
 162 c
 163         write (ulsort,texte(langue,6))
 164         write (ulsort,texte(langue,7)) jfin
 165         write (ulsort,texte(langue,8)) nbanci
 166         codret = 1
 167 c
 168       endif
 169 c
 170 c====
 171 c 4. la fin
 172 c====
 173 c
 174       if ( codret.ne.0 ) then
 175 c
 176 #include "envex2.h"
 177 c
 178       write (ulsort,texte(langue,1)) 'Sortie', nompro
 179       write (ulsort,texte(langue,2)) codret
 180 c
 181       endif
 182 c
 183 #ifdef _DEBUG_HOMARD_
 184       write (ulsort,texte(langue,1)) 'Sortie', nompro
 185       call dmflsh (iaux)
 186 #endif
 187 c
 188       end