src/tool/Utilitaire/utehex.F

   1       subroutine utehex ( nbheto, nbhfal, nbhaal, nbqual,
   2      >                    somare, arequa,
   3      >                    quahex, coquhe, arehex,
   4      >                    nmprog, avappr, ulbila,
   5      >                    ulsort, langue, codret )
   6 c ______________________________________________________________________
   7 c
   8 c                             H O M A R D
   9 c
  10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  11 c
  12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  13 c aupres des huissiers de justice Simart et Lavoir a Clamart
  14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  15 c aupres des huissiers de justice
  16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  17 c
  18 c    HOMARD est une marque deposee d'Electricite de France
  19 c
  20 c Copyright EDF 1996
  21 c Copyright EDF 1998
  22 c Copyright EDF 2002
  23 c Copyright EDF 2020
  24 c ______________________________________________________________________
  25 c
  26 c    UTilitaire - Examen des HEXaedres
  27 c    --           -          ---
  28 c ______________________________________________________________________
  29 c .        .     .        .                                            .
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . nbheto . e   .   1    . nombre de hexaedres a examiner             .
  33 c . nbhfal . e   .   1    . nombre de hexas par faces pour les allocs  .
  34 c . nbhaal . e   .   1    . nbre de hexas par aretes pour les allocs   .
  35 c . nbqual . e   .   1    . nombre de quadrangles pour les allocations .
  36 c . somare . e   . 2*nbar . numeros des extremites d'arete             .
  37 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  38 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  39 c . coquhe . e   .nbhecf*6. code des 6 quadrangles des hexaedres       .
  40 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
  41 c . nmprog . e   . char*  . nom du programme a pister                  .
  42 c . avappr . e   .   1    . 1 : impression avant l'appel a "nmprog"    .
  43 c .        .     .        . 2 : impression apres l'appel a "nmprog"    .
  44 c . ulbila . e   .   1    . unite logitee d'ecriture du bilan          .
  45 c . ulsort . e   .   1    . numero d'unite logitee de la liste standard.
  46 c . langue . e   .    1   . langue des messages                        .
  47 c .        .     .        . 1 : francais, 2 : anglais                  .
  48 c . codret . es  .    1   . code de retour des modules                 .
  49 c .        .     .        . 0 : pas de probleme                        .
  50 c .        .     .        . >0 : probleme dans le controle             .
  51 c ______________________________________________________________________
  52 c
  53 c====
  54 c 0. declarations et dimensionnement
  55 c====
  56 c
  57 c 0.1. ==> generalites
  58 c
  59       implicit none
  60       save
  61 c
  62       character*6 nompro
  63       parameter ( nompro = 'UTEHEX' )
  64 c
  65 #include "nblang.h"
  66 c
  67 c 0.2. ==> communs
  68 c
  69 #include "envex1.h"
  70 c
  71 #include "impr02.h"
  72 c
  73 c 0.3. ==> arguments
  74 c
  75       integer nbheto, nbhfal, nbhaal, nbqual
  76       integer somare(2,*)
  77       integer arequa(nbqual,4)
  78       integer quahex(nbhfal,6), coquhe(nbhfal,6), arehex(nbhaal,12)
  79 c
  80       character*(*) nmprog
  81 c
  82       integer avappr
  83 c
  84       integer ulbila
  85       integer ulsort, langue, codret
  86 c
  87 c 0.4. ==> variables locales
  88 c
  89       integer codre0
  90       integer iaux, jaux
  91       integer lehexa, lehex0
  92       integer f1, f2, f3, f4, f5, f6
  93       integer listar(12), listso(8)
  94 c
  95       integer nbmess
  96       parameter ( nbmess = 20 )
  97       character*80 texte(nblang,nbmess)
  98 c
  99 c 0.5. ==> initialisations
 100 c ______________________________________________________________________
 101 c
 102 c====
 103 c 1. messages
 104 c====
 105 c
 106 #include "impr01.h"
 107 c
 108 #ifdef _DEBUG_HOMARD_
 109       write (ulsort,texte(langue,1)) 'Entree', nompro
 110       call dmflsh (iaux)
 111 #endif
 112 c
 113       texte(1,6) = '(5x,''Controle des '',i10,'' hexaedres.'')'
 114       texte(1,7) =
 115      > '(''L''''hexaedre '',i10,'' a des '',a,'' identiques :'',12i10)'
 116       texte(1,10) =
 117      > '(''Les aretes de l''''hexaedre '',i10,'' ne se suivent pas.'')'
 118       texte(1,16) =
 119      > '(5x,''Pas de probleme dans la definition des hexaedres'',/)'
 120       texte(1,17) = '(/,''Mauvais code pour '',a,'' : '',i10,/)'
 121       texte(1,18) = '(/,''.. A l''''entree de '',a,'' :'',/)'
 122       texte(1,19) = '(/,''.. Avant appel a '',a,'' :'',/)'
 123       texte(1,20) = '(/,''.. Apres appel a '',a,'' :'',/)'
 124 c
 125       texte(2,6) = '(5x,''Control of '',i10,'' hexahedrons.'')'
 126       texte(2,7) =
 127      > '(''Hexahedron # '',i10,'' has got similar '',a,'':'',12i10)'
 128       texte(2,10) =
 129      > '(''Edges of hexahedron '',i10,'' are not following.'')'
 130       texte(2,16) = '(5x,''No problem with hexaedra definition'',/)'
 131       texte(2,17) = '(/,''Bad code for '',a,'' : '',i10,/)'
 132       texte(2,18) = '(/,''.. At the beginning of '',a,'' :'',/)'
 133       texte(2,19) = '(/,''.. Before calling '',a,'' :'',/)'
 134       texte(2,20) = '(/,''.. After calling '',a,'' :'',/)'
 135 c
 136 #include "impr03.h"
 137 c
 138 #ifdef _DEBUG_HOMARD_
 139       if ( avappr.ge.0 .and. avappr.le.2 ) then
 140         write (ulsort,texte(langue,18+avappr)) nmprog
 141       else
 142         write (ulsort,texte(langue,17)) nmprog, avappr
 143       endif
 144 #endif
 145       write (ulsort,texte(langue,6)) nbheto
 146 c
 147       codret = 0
 148 c
 149 c====
 150 c 2. verification
 151 c====
 152 c
 153       do 20 , lehex0 = 1 , nbheto
 154 c
 155         lehexa = lehex0
 156 c
 157         codre0 = 0
 158 c
 159 c 2.1. ==> les faces doivent etre differentes ...
 160 c
 161         if ( lehexa.le.nbhfal ) then
 162 c
 163           f1 = quahex(lehexa,1)
 164           f2 = quahex(lehexa,2)
 165           f3 = quahex(lehexa,3)
 166           f4 = quahex(lehexa,4)
 167           f5 = quahex(lehexa,5)
 168           f6 = quahex(lehexa,6)
 169 c
 170           if ( f1.eq.f2 .or.
 171      >         f1.eq.f3 .or.
 172      >         f1.eq.f4 .or.
 173      >         f1.eq.f5 .or.
 174      >         f1.eq.f6 .or.
 175      >         f2.eq.f3 .or.
 176      >         f2.eq.f4 .or.
 177      >         f2.eq.f5 .or.
 178      >         f2.eq.f6 .or.
 179      >         f3.eq.f4 .or.
 180      >         f3.eq.f5 .or.
 181      >         f3.eq.f6 .or.
 182      >         f4.eq.f5 .or.
 183      >         f4.eq.f6 .or.
 184      >         f5.eq.f6 ) then
 185             codre0 = 1
 186             write (ulsort,texte(langue,7)) lehexa, mess14(langue,3,8),
 187      >                                     f1, f2, f3, f4, f5, f6
 188             write (ulbila,texte(langue,7)) lehexa, mess14(langue,3,8),
 189      >                                     f1, f2, f3, f4, f5, f6
 190           endif
 191 c
 192         endif
 193 c
 194 c 2.2. ==> les aretes doivent etre differentes ...
 195 c
 196         if ( codre0.eq.0 ) then
 197 c
 198         call utashe ( lehexa,
 199      >                nbqual, nbhfal, nbhaal,
 200      >                somare, arequa,
 201      >                quahex, coquhe, arehex,
 202      >                listar, listso )
 203 c
 204         endif
 205 c
 206         if ( codre0.eq.0 ) then
 207 c
 208         do 22 , iaux = 1 , 11
 209           do 221 , jaux = iaux+1 , 12
 210             if ( listar(iaux).eq.listar(jaux) ) then
 211               codre0 = 1
 212             endif
 213   221    continue
 214    22    continue
 215 c
 216         if ( codre0.ne.0 ) then
 217           write (ulsort,texte(langue,7)) lehexa, mess14(langue,3,1),
 218      >                                   (listar(iaux),iaux=1,12)
 219           write (ulbila,texte(langue,7)) lehexa, mess14(langue,3,1),
 220      >                                   (listar(iaux),iaux=1,12)
 221         endif
 222 c
 223         endif
 224 c
 225 c 2.3. ==> les aretes doivent etre conformes au modele HOMARD ...
 226 c
 227         if ( codre0.eq.0 ) then
 228 c
 229         iaux = 6
 230         jaux = 12
 231 c
 232 #ifdef _DEBUG_HOMARD_
 233       write (ulsort,texte(langue,3)) 'UTVAR0', nompro
 234 #endif
 235         call utvar0 ( iaux, lehexa, jaux, listar, somare,
 236      >                ulbila, ulsort, langue, codre0 )
 237 c
 238         endif
 239 c
 240 c 2.4. ==> les sommets doivent etre differents ...
 241 c
 242         if ( codre0.eq.0 ) then
 243 c
 244         do 24 , iaux = 1 , 7
 245           do 241 , jaux = iaux+1 , 8
 246             if ( listso(iaux).eq.listso(jaux) ) then
 247               codre0 = 1
 248             endif
 249   241    continue
 250    24    continue
 251 c
 252         if ( codre0.ne.0 ) then
 253           write (ulsort,texte(langue,7)) lehexa, mess14(langue,3,-1),
 254      >                                   (listso(iaux),iaux=1,8)
 255           write (ulbila,texte(langue,7)) lehexa, mess14(langue,3,-1),
 256      >                                   (listso(iaux),iaux=1,8)
 257         endif
 258 c
 259         endif
 260 c
 261 c 2.5. ==> cumul des erreurs
 262 c
 263         codret = codret + codre0
 264 c
 265    20 continue
 266 c
 267 c 2.6. ==> tout va bien
 268 c
 269       if ( codret.eq.0 ) then
 270         write (ulsort,texte(langue,16))
 271         write (ulbila,texte(langue,16))
 272       endif
 273 c
 274 c====
 275 c 3. la fin
 276 c====
 277 c
 278       if ( codret.ne.0 ) then
 279 c
 280 #include "envex2.h"
 281 c
 282       write (ulsort,texte(langue,1)) 'Sortie', nompro
 283       write (ulsort,texte(langue,2)) codret
 284 c
 285       endif
 286 c
 287 #ifdef _DEBUG_HOMARD_
 288       write (ulsort,texte(langue,1)) 'Sortie', nompro
 289       call dmflsh (iaux)
 290 #endif
 291 c
 292       end