src/tool/Utilitaire/utepen.F

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