src/tool/Utilitaire/uteare.F

   1       subroutine uteare ( nbarto, nbnoto, somare,
   2      >                    nmprog, avappr, ulbila,
   3      >                    ulsort, langue, codret )
   4 c ______________________________________________________________________
   5 c
   6 c                             H O M A R D
   7 c
   8 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   9 c
  10 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  11 c aupres des huissiers de justice Simart et Lavoir a Clamart
  12 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  13 c aupres des huissiers de justice
  14 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  15 c
  16 c    HOMARD est une marque deposee d'Electricite de France
  17 c
  18 c Copyright EDF 1996
  19 c Copyright EDF 1998
  20 c Copyright EDF 2002
  21 c Copyright EDF 2020
  22 c ______________________________________________________________________
  23 c
  24 c    UTilitaire - Examen des AREtes
  25 c    --           -          ---
  26 c ______________________________________________________________________
  27 c .        .     .        .                                            .
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . nbarto . e   .   1    . nombre d'aretes a examiner                 .
  31 c . nbnoto . e   .   1    . nombre de sommets enregistres              .
  32 c . somare . e   .nbarto*2. numeros des extremites d'arete             .
  33 c . nmprog . e   . char*  . nom du programme a pister                  .
  34 c . avappr . e   .   1    . 1 : impression avant l'appel a "nmprog"    .
  35 c .        .     .        . 2 : impression apres l'appel a "nmprog"    .
  36 c . ulbila . e   .   1    . unite logique d'ecriture du bilan          .
  37 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  38 c . langue . e   .    1   . langue des messages                        .
  39 c .        .     .        . 1 : francais, 2 : anglais                  .
  40 c . codret . es  .    1   . code de retour des modules                 .
  41 c .        .     .        . 0 : pas de probleme                        .
  42 c .        .     .        . >0 : nombre de problemes rencontres        .
  43 c ______________________________________________________________________
  44 c
  45 c====
  46 c 0. declarations et dimensionnement
  47 c====
  48 c
  49 c 0.1. ==> generalites
  50 c
  51       implicit none
  52       save
  53 c
  54       character*6 nompro
  55       parameter ( nompro = 'UTEARE' )
  56 c
  57 #include "nblang.h"
  58 c
  59 c 0.2. ==> communs
  60 c
  61 #include "envex1.h"
  62 c
  63 c 0.3. ==> arguments
  64 c
  65       integer nbarto, nbnoto
  66       integer somare(2,*)
  67 c
  68       character*(*) nmprog
  69 c
  70       integer avappr
  71 c
  72       integer ulbila
  73       integer ulsort, langue, codret
  74 c
  75 c 0.4. ==> variables locales
  76 c
  77       integer iaux, jaux
  78       integer codre0
  79 c
  80       integer nbmess
  81       parameter ( nbmess = 20 )
  82       character*80 texte(nblang,nbmess)
  83 c
  84 c 0.5. ==> initialisations
  85 c ______________________________________________________________________
  86 c
  87 c====
  88 c 1. messages
  89 c====
  90 c
  91 #include "impr01.h"
  92 c
  93 #ifdef _DEBUG_HOMARD_
  94       write (ulsort,texte(langue,1)) 'Entree', nompro
  95       call dmflsh (iaux)
  96 #endif
  97 c
  98       texte(1,5) = '(5x,''Controle des '',i10,'' aretes.'')'
  99       texte(1,6) = '(''Arete :'',i10)'
 100       texte(1,7) = '(''Sommets :'',2i10,/)'
 101       texte(1,8) = '(''Les deux sommets sont confondus.'')'
 102       texte(1,9) = '(''Le numero du sommet'',i2,'' est mauvais.'')'
 103       texte(1,16) =
 104      > '(5x,''Pas de probleme dans la definition des aretes'',/)'
 105       texte(1,17) = '(/,''Mauvais code pour '',a,'' : '',i10,/)'
 106       texte(1,18) = '(/,''.. A l''''entree de '',a,'' :'',/)'
 107       texte(1,19) = '(/,''.. Avant appel a '',a,'' :'',/)'
 108       texte(1,20) = '(/,''.. Apres appel a '',a,'' :'',/)'
 109 c
 110       texte(2,5) = '(5x,''Control of '',i10,'' edges.'')'
 111       texte(2,6) = '(''Edge :'',i10)'
 112       texte(2,7) = '(''Vertices :'',2i10,/)'
 113       texte(2,8) = '(''Nodes are similar.'')'
 114       texte(2,9) = '(''Wrong number for vertice #'',i2)'
 115       texte(2,16) = '(5x,''No problem with edge definition'',/)'
 116       texte(2,17) = '(/,''Bad code for '',a,'' : '',i10,/)'
 117       texte(2,18) = '(/,''.. At the beginning of '',a,'' :'',/)'
 118       texte(2,19) = '(/,''.. Before calling '',a,'' :'',/)'
 119       texte(2,20) = '(/,''.. After calling '',a,'' :'',/)'
 120 c
 121 #ifdef _DEBUG_HOMARD_
 122       if ( avappr.ge.0 .and. avappr.le.2 ) then
 123         write (ulsort,texte(langue,18+avappr)) nmprog
 124       else
 125         write (ulsort,texte(langue,17)) nmprog, avappr
 126       endif
 127 #endif
 128       write (ulsort,texte(langue,5)) nbarto
 129 c
 130 c====
 131 c 2. verification
 132 c====
 133 c
 134       codret = 0
 135       jaux = 3*nbnoto
 136 c
 137       do 21 , iaux = 1 , nbarto
 138 c
 139         codre0 = 0
 140 c
 141 c 2.1. ==> les deux sommets doivent etre differents
 142 c
 143         if ( somare(1,iaux).eq.somare(2,iaux) ) then
 144           codre0 = 1
 145           write (ulsort,texte(langue,8))
 146           write (ulbila,texte(langue,8))
 147 c
 148 c 2.2. ==> le numero de noeud est forcement positif
 149 c
 150         elseif ( somare(1,iaux).le.0 ) then
 151           codre0 = 2
 152           write (ulsort,texte(langue,9)) 1
 153           write (ulbila,texte(langue,9)) 1
 154        elseif ( somare(2,iaux).le.0 ) then
 155           codre0 = 3
 156           write (ulsort,texte(langue,9)) 2
 157           write (ulbila,texte(langue,9)) 2
 158 c
 159 c 2.3. ==> le numero est borne : on ne connait pas toujours precisement
 160 c          le maximum, mais on est sur que c'est inferieur a 3 fois le
 161 c          nombre de noeuds actuel. Cela permet de pieger les
 162 c          debordements de tableau
 163 c
 164         elseif ( somare(1,iaux).gt.jaux ) then
 165           codre0 = 4
 166           write (ulsort,texte(langue,9)) 1
 167           write (ulbila,texte(langue,9)) 1
 168         elseif ( somare(2,iaux).gt.jaux ) then
 169           codre0 = 5
 170           write (ulsort,texte(langue,9)) 2
 171           write (ulbila,texte(langue,9)) 2
 172         endif
 173 c
 174         if ( codre0.ne.0 ) then
 175           codret = codret + 1
 176           write (ulsort,texte(langue,6)) iaux
 177           write (ulbila,texte(langue,6)) iaux
 178           write (ulsort,texte(langue,7)) somare(1,iaux), somare(2,iaux)
 179           write (ulbila,texte(langue,7)) somare(1,iaux), somare(2,iaux)
 180         endif
 181 c
 182    21 continue
 183 c
 184 c 2.2. ==> tout va bien
 185 c
 186       if ( codret.eq.0 ) then
 187         write (ulsort,texte(langue,16))
 188         write (ulbila,texte(langue,16))
 189       endif
 190 c
 191 c====
 192 c 3. la fin
 193 c====
 194 c
 195       if ( codret.ne.0 ) then
 196 c
 197 #include "envex2.h"
 198 c
 199       write (ulsort,texte(langue,1)) 'Sortie', nompro
 200       write (ulsort,texte(langue,2)) codret
 201 c
 202       endif
 203 c
 204 #ifdef _DEBUG_HOMARD_
 205       write (ulsort,texte(langue,1)) 'Sortie', nompro
 206       call dmflsh (iaux)
 207 #endif
 208 c
 209       end