src/tool/Utilitaire/utetri.F

   1       subroutine utetri ( nbtrto, nbtral,
   2      >                    aretri, somare,
   3      >                    nmprog, avappr, ulbila,
   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 - Examen des TRIangles
  26 c    --           -          ---
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . nbtrto . e   .   1    . nombre de triangles a examiner             .
  32 c . nbtral . e   .   1    . nombre de triangles pour les allocations   .
  33 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  34 c . somare . e   . 2*nbar . numeros des extremites d'arete             .
  35 c . nmprog . e   . char*  . nom du programme a pister                  .
  36 c . avappr . e   .   1    . 1 : impression avant l'appel a "nmprog"    .
  37 c .        .     .        . 2 : impression apres l'appel a "nmprog"    .
  38 c . ulbila . e   .   1    . unite logique d'ecriture du bilan          .
  39 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  40 c . langue . e   .    1   . langue des messages                        .
  41 c .        .     .        . 1 : francais, 2 : anglais                  .
  42 c . codret . es  .    1   . code de retour des modules                 .
  43 c .        .     .        . 0 : pas de probleme                        .
  44 c .        .     .        . >0 : probleme dans le controle             .
  45 c ______________________________________________________________________
  46 c
  47 c====
  48 c 0. declarations et dimensionnement
  49 c====
  50 c
  51 c 0.1. ==> generalites
  52 c
  53       implicit none
  54       save
  55 c
  56       character*6 nompro
  57       parameter ( nompro = 'UTETRI' )
  58 c
  59 #include "nblang.h"
  60 c
  61 c 0.2. ==> communs
  62 c
  63 #include "envex1.h"
  64 c
  65 c 0.3. ==> arguments
  66 c
  67       integer nbtrto, nbtral
  68       integer aretri(nbtral,3)
  69       integer somare(2,*)
  70 c
  71       character*(*) nmprog
  72 c
  73       integer avappr
  74 c
  75       integer ulbila
  76       integer ulsort, langue, codret
  77 c
  78 c 0.4. ==> variables locales
  79 c
  80       integer codre0
  81       integer iaux, jaux, kaux
  82       integer a1, a2, a3
  83       integer sa1a2, sa2a3, sa3a1
  84       integer listar(3)
  85 c
  86       integer nbmess
  87       parameter ( nbmess = 20 )
  88       character*80 texte(nblang,nbmess)
  89 c
  90 c 0.5. ==> initialisations
  91 c ______________________________________________________________________
  92 c
  93 c====
  94 c 1. messages
  95 c====
  96 c
  97 #include "impr01.h"
  98 c
  99 #ifdef _DEBUG_HOMARD_
 100       write (ulsort,texte(langue,1)) 'Entree', nompro
 101       call dmflsh (iaux)
 102 #endif
 103 c
 104       texte(1,6) = '(5x,''Controle des '',i10,'' triangles.'')'
 105       texte(1,7) =
 106      > '(''Le triangle '',i10,'' a des aretes confondues :'',3i10)'
 107       texte(1,8) =
 108      > '(''Le triangle '',i10,'' a des noeuds confondus :'',3i10)'
 109       texte(1,16) =
 110      > '(5x,''Pas de probleme dans la definition des triangles'',/)'
 111       texte(1,17) = '(/,''Mauvais code pour '',a,'' : '',i10,/)'
 112       texte(1,18) = '(/,''.. A l''''entree de '',a,'' :'',/)'
 113       texte(1,19) = '(/,''.. Avant appel a '',a,'' :'',/)'
 114       texte(1,20) = '(/,''.. Apres appel a '',a,'' :'',/)'
 115 c
 116       texte(2,6) = '(5x,''Control of '',i10,'' triangles.'')'
 117       texte(2,7) =
 118      > '(''Edges of triangle # '',i10,'' are similar :'',3i10)'
 119       texte(2,8) =
 120      > '(''Nodes of triangle # '',i10,'' are similar :'',3i10)'
 121       texte(2,16) = '(5x,''No problem with triangle definition'',/)'
 122       texte(2,17) = '(/,''Bad code for '',a,'' : '',i10,/)'
 123       texte(2,18) = '(/,''.. At the beginning of '',a,'' :'',/)'
 124       texte(2,19) = '(/,''.. Before calling '',a,'' :'',/)'
 125       texte(2,20) = '(/,''.. After calling '',a,'' :'',/)'
 126 c
 127 #ifdef _DEBUG_HOMARD_
 128       if ( avappr.ge.0 .and. avappr.le.2 ) then
 129         write (ulsort,texte(langue,18+avappr)) nmprog
 130       else
 131         write (ulsort,texte(langue,17)) nmprog, avappr
 132       endif
 133 #endif
 134       write (ulsort,texte(langue,6)) nbtrto
 135 c
 136       codret = 0
 137 c
 138 c====
 139 c 2. verification
 140 c====
 141 c
 142       do 20 , iaux = 1 , nbtrto
 143 c
 144         codre0 = 0
 145 c
 146 c 2.1. ==> les aretes doivent etre differentes ...
 147 c
 148         a1 = aretri(iaux,1)
 149         a2 = aretri(iaux,2)
 150         a3 = aretri(iaux,3)
 151 c
 152         if ( a1.eq.a2 .or.
 153      >       a2.eq.a3 .or.
 154      >       a3.eq.a1 ) then
 155           codre0 = 1
 156           write (ulsort,texte(langue,7)) iaux, a1, a2, a3
 157           write (ulbila,texte(langue,7)) iaux, a1, a2, a3
 158         endif
 159 c
 160 c 2.2. ==> les aretes doivent se suivre ...
 161 c
 162         if ( codre0.eq.0 ) then
 163 c
 164         listar(1) = a1
 165         listar(2) = a2
 166         listar(3) = a3
 167         jaux = 2
 168         kaux = 3
 169 c
 170 #ifdef _DEBUG_HOMARD_
 171       write (ulsort,texte(langue,3)) 'UTVAR0', nompro
 172 #endif
 173         call utvar0 ( jaux, iaux, kaux, listar, somare,
 174      >                ulbila, ulsort, langue, codre0 )
 175 c
 176         endif
 177 c
 178 c 2.3. ==> les sommets doivent etre differents ...
 179 c
 180         if ( codre0.eq.0 ) then
 181 c
 182 #ifdef _DEBUG_HOMARD_
 183       write (ulsort,texte(langue,3)) 'UTSOTR', nompro
 184 #endif
 185         call utsotr ( somare, a1, a2, a3,
 186      >                sa1a2, sa2a3, sa3a1 )
 187 c
 188         if ( sa1a2.eq.sa2a3 .or.
 189      >       sa1a2.eq.sa3a1 .or.
 190      >       sa2a3.eq.sa3a1 ) then
 191           codre0 = 1
 192           write (ulsort,texte(langue,8)) iaux, sa1a2, sa2a3, sa3a1
 193           write (ulbila,texte(langue,8)) iaux, sa1a2, sa2a3, sa3a1
 194         endif
 195 c
 196         endif
 197 c
 198 c 2.4. ==> cumul des erreurs
 199 c
 200         codret = codret + codre0
 201 c
 202    20 continue
 203 c
 204 c 2.4. ==> tout va bien
 205 c
 206       if ( codret.eq.0 ) then
 207         write (ulsort,texte(langue,16))
 208         write (ulbila,texte(langue,16))
 209       endif
 210 c
 211 c====
 212 c 3. la fin
 213 c====
 214 c
 215       if ( codret.ne.0 ) then
 216 c
 217 #include "envex2.h"
 218 c
 219       write (ulsort,texte(langue,1)) 'Sortie', nompro
 220       write (ulsort,texte(langue,2)) codret
 221 c
 222       endif
 223 c
 224 #ifdef _DEBUG_HOMARD_
 225       write (ulsort,texte(langue,1)) 'Sortie', nompro
 226       call dmflsh (iaux)
 227 #endif
 228 c
 229       end