src/tool/Utilitaire/utepyr.F

   1       subroutine utepyr ( nbpyto, nbyfal, nbyaal, nbtral,
   2      >                    somare, aretri,
   3      >                    facpyr, cofapy, arepyr,
   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 PYRamides
  27 c    --           -          ---
  28 c ______________________________________________________________________
  29 c .        .     .        .                                            .
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . nbpyto . e   .   1    . nombre de pyramides a examiner             .
  33 c . nbyfal . e   .   1    . nbre de pyras par faces pour les allocs    .
  34 c . nbyaal . e   .   1    . nbre de pyras par aretes pour les allocs   .
  35 c . nbtral . e   .   1    . nombre de triangles pour les allocations   .
  36 c . somare . e   . 2*nbar . numeros des extremites d'arete             .
  37 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  38 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  39 c . cofapy . e   .nbpycf*5. codes des 5 faces des pyramides            .
  40 c . arepyr . e   .nbyaal*8. numeros des 8 aretes des pyramides         .
  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 = 'UTEPYR' )
  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 nbpyto, nbyfal, nbyaal, nbtral
  76       integer somare(2,*)
  77       integer aretri(nbtral,4)
  78       integer facpyr(nbyfal,5), cofapy(nbyfal,5), arepyr(nbyaal,8)
  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 nbpyal
  92       integer lapyra, lapyr0
  93       integer f1, f2, f3, f4
  94       integer listar(8), listso(5)
  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 #include "impr03.h"
 110 c
 111 #ifdef _DEBUG_HOMARD_
 112       write (ulsort,texte(langue,1)) 'Entree', nompro
 113       call dmflsh (iaux)
 114 #endif
 115 c
 116       texte(1,6) = '(5x,''Controle des '',i10,'' pyramides.'')'
 117       texte(1,7) =
 118      > '(''La pyramide '',i10,'' a des '',a,'' identiques :'',12i10)'
 119       texte(1,10) =
 120      > '(''Les aretes de la pyramide '',i10,'' ne se suivent pas.'')'
 121       texte(1,16) =
 122      > '(5x,''Pas de probleme dans la definition des pyramides'',/)'
 123       texte(1,17) = '(/,''Mauvais code pour '',a,'' : '',i10,/)'
 124       texte(1,18) = '(/,''.. A l''''entree de '',a,'' :'',/)'
 125       texte(1,19) = '(/,''.. Avant appel a '',a,'' :'',/)'
 126       texte(1,20) = '(/,''.. Apres appel a '',a,'' :'',/)'
 127 c
 128       texte(2,6) = '(5x,''Control of '',i10,'' pyramids.'')'
 129       texte(2,7) =
 130      > '(''Pyramid # '',i10,'' has got similar '',a,'':'',12i10)'
 131       texte(2,10) =
 132      > '(''Edges of pyramid '',i10,'' are not following.'')'
 133       texte(2,16) = '(5x,''No problem with pyramid definition'',/)'
 134       texte(2,17) = '(/,''Bad code for '',a,'' : '',i10,/)'
 135       texte(2,18) = '(/,''.. At the beginning of '',a,'' :'',/)'
 136       texte(2,19) = '(/,''.. Before calling '',a,'' :'',/)'
 137       texte(2,20) = '(/,''.. After calling '',a,'' :'',/)'
 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)) nbpyto
 147 cgn      write (ulsort,*) nbyfal, nbyaal
 148 c
 149 c 1.3. ==> constantes
 150 c
 151       codret = 0
 152 c
 153 c====
 154 c 2. verification
 155 c====
 156 c
 157       nbpyal = nbyfal + nbyaal
 158 c
 159       do 20 , lapyr0 = 1 , nbpyto
 160 c
 161         lapyra = lapyr0
 162 c
 163         codre0 = 0
 164 c
 165 c 2.1. ==> les faces doivent etre differentes ...
 166 c
 167         if ( lapyra.le.nbyfal ) then
 168 c
 169           f1 = facpyr(lapyra,1)
 170           f2 = facpyr(lapyra,2)
 171           f3 = facpyr(lapyra,3)
 172           f4 = facpyr(lapyra,4)
 173 c
 174           if ( f1.eq.f2 .or.
 175      >         f1.eq.f3 .or.
 176      >         f1.eq.f4 .or.
 177      >         f2.eq.f3 .or.
 178      >         f2.eq.f4 .or.
 179      >         f3.eq.f4 ) then
 180             codre0 = 1
 181             write (ulsort,texte(langue,7)) lapyra, mess14(langue,3,2),
 182      >                                     f1, f2, f3, f4
 183             write (ulbila,texte(langue,7)) lapyra, mess14(langue,3,2),
 184      >                                     f1, f2, f3, f4
 185           endif
 186 c
 187         endif
 188 c
 189 c 2.2. ==> les aretes doivent etre differentes ...
 190 c
 191         if ( codre0.eq.0 ) then
 192 c
 193         call utaspy ( lapyra,
 194      >                nbtral, nbyfal, nbyaal,
 195      >                somare, aretri,
 196      >                facpyr, cofapy, arepyr,
 197      >                listar, listso )
 198 c
 199         endif
 200 c
 201         if ( codre0.eq.0 ) then
 202 c
 203         do 221 , iaux = 1 , 7
 204           do 222 , jaux = iaux+1 , 8
 205             if ( listar(iaux).eq.listar(jaux) ) then
 206               codre0 = 1
 207             endif
 208   222    continue
 209   221    continue
 210 c
 211         if ( codre0.ne.0 ) then
 212           write (ulsort,texte(langue,7)) lapyra, mess14(langue,3,1),
 213      >                                   (listar(iaux),iaux=1,8)
 214           write (ulbila,texte(langue,7)) lapyra, mess14(langue,3,1),
 215      >                                   (listar(iaux),iaux=1,8)
 216         endif
 217 c
 218         endif
 219 c
 220 c 2.3. ==> les aretes doivent etre conformes au modele HOMARD ...
 221 c
 222         if ( codre0.eq.0 ) then
 223 c
 224         iaux = 5
 225         jaux = 8
 226 c
 227 #ifdef _DEBUG_HOMARD_
 228       write (ulsort,texte(langue,3)) 'UTVAR0', nompro
 229 #endif
 230         call utvar0 ( iaux, lapyra, jaux, listar, somare,
 231      >                ulbila, ulsort, langue, codre0 )
 232 c
 233         endif
 234 c
 235 c 2.4. ==> les sommets doivent etre differents ...
 236 c
 237         if ( codre0.eq.0 ) then
 238 c
 239         do 24 , iaux = 1 , 4
 240           do 241 , jaux = iaux+1 , 5
 241             if ( listso(iaux).eq.listso(jaux) ) then
 242               codre0 = 1
 243             endif
 244   241    continue
 245    24    continue
 246 c
 247         if ( codre0.ne.0 ) then
 248           write (ulsort,texte(langue,7)) lapyra, mess14(langue,3,-1),
 249      >                                   (listso(iaux),iaux=1,5)
 250           write (ulbila,texte(langue,7)) lapyra, mess14(langue,3,-1),
 251      >                                   (listso(iaux),iaux=1,5)
 252         endif
 253 c
 254         endif
 255 c
 256 c 2.5. ==> cumul des erreurs
 257 c
 258         codret = codret + codre0
 259 c
 260    20 continue
 261 c
 262 c 2.6. ==> tout va bien
 263 c
 264       if ( codret.eq.0 ) then
 265         write (ulsort,texte(langue,16))
 266         write (ulbila,texte(langue,16))
 267       endif
 268 c
 269 c====
 270 c 3. la fin
 271 c====
 272 c
 273       if ( codret.ne.0 ) then
 274 c
 275 #include "envex2.h"
 276 c
 277       write (ulsort,texte(langue,1)) 'Sortie', nompro
 278       write (ulsort,texte(langue,2)) codret
 279 c
 280       endif
 281 c
 282 #ifdef _DEBUG_HOMARD_
 283       write (ulsort,texte(langue,1)) 'Sortie', nompro
 284       call dmflsh (iaux)
 285 #endif
 286 c
 287       end