src/tool/Utilitaire/utvar0.F

   1       subroutine utvar0 ( typver, numele, nbaret, listar, somare,
   2      >                    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 - Verification des ARetes - 0
  25 c    --           -                --       -
  26 c ______________________________________________________________________
  27 c .        .     .        .                                            .
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . typver . e   .   1    . type de verification :                     .
  31 c .        .     .        . 0 : boucle fermee                          .
  32 c .        .     .        . -1 : continuite, ouverture aux 2 extremites.
  33 c .        .     .        . n>0 : de l'element de type n ad-hoc        .
  34 c . numele . e   .   1    . numero de l'element si typver = 0          .
  35 c . nbaret . e   .   1    . nombre d'aretes a examiner                 .
  36 c . listar . e   . nbaret . liste des aretes a examiner                .
  37 c . somare . e   . 2*nbar . numeros des extremites d'arete             .
  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 .        .     .        . 1 : pas assez d'arete dans la liste        .
  45 c .        .     .        . 2 : mauvais type de verification           .
  46 c .        .     .        . 10 : les aretes ne se suivent pas          .
  47 c .        .     .        . 11 : la suite des aretes ne ferme pas      .
  48 c ______________________________________________________________________
  49 c
  50 c====
  51 c 0. declarations et dimensionnement
  52 c====
  53 c
  54 c 0.1. ==> generalites
  55 c
  56       implicit none
  57       save
  58 c
  59       character*6 nompro
  60       parameter ( nompro = 'UTVAR0' )
  61 c
  62 #include "nblang.h"
  63 c
  64 c 0.2. ==> communs
  65 c
  66 #include "envex1.h"
  67 c
  68 #include "impr02.h"
  69 c
  70 c 0.3. ==> arguments
  71 c
  72       integer typver, numele, nbaret
  73       integer listar(nbaret)
  74       integer somare(2,*)
  75 c
  76       integer ulbila
  77       integer ulsort, langue, codret
  78 c
  79 c 0.4. ==> variables locales
  80 c
  81       integer iaux, jaux, kaux
  82       integer kvoulu
  83       integer ulaux
  84       integer laret1, laret2
  85       integer lesom1
  86       integer nbaref(7)
  87       integer arsote(3,4)
  88       integer arsohe(3,8)
  89       integer arsopy(4,5)
  90       integer arsope(3,6)
  91       integer s1
  92 c
  93       integer nbmess
  94       parameter ( nbmess = 20 )
  95       character*80 texte(nblang,nbmess)
  96 c
  97 c 0.5. ==> initialisations
  98 c
  99       data nbaref / 1, 3, 6, 4, 8, 12, 9 /
 100 c
 101 c     Pour chaque sommet j, arsoxx(i,j) donne le numero local dec
 102 c     la i-eme arete qui y aboutit.
 103 c
 104 c     pour un tetraedre :
 105 c
 106 c       a1 est l'arete entre s1 et s2
 107 c       a2 est l'arete entre s1 et s3
 108 c       a3 est l'arete entre s1 et s4
 109 c       a4 est l'arete entre s2 et s3
 110 c       a5 est l'arete entre s2 et s4
 111 c       a6 est l'arete entre s3 et s4
 112 c
 113       data arsote / 1, 2, 3,   1, 4, 5,   2, 4, 6,   3, 5, 6 /
 114 c
 115 c     pour un hexaedre :
 116 c
 117 c       a1 est l'arete entre s1 et s2
 118 c       a2 est l'arete entre s1 et s4
 119 c       a3 est l'arete entre s2 et s3
 120 c       a4 est l'arete entre s3 et s4
 121 c       a5 est l'arete entre s1 et s6
 122 c       a6 est l'arete entre s2 et s5
 123 c       a7 est l'arete entre s4 et s7
 124 c       a8 est l'arete entre s3 et s8
 125 c       a9 est l'arete entre s5 et s6
 126 c       a10 est l'arete entre s6 et s7
 127 c       a11 est l'arete entre s5 et s8
 128 c       a12 est l'arete entre s7 et s8
 129 c
 130       data arsohe / 1, 2, 5,   1, 3, 6,   3, 4, 8,    2, 4, 7,
 131      >              6, 9, 11,  5, 9, 10,  7, 10, 12,  8, 11, 12 /
 132 c
 133 c     pour une pyramide :
 134 c
 135 c       a1 est l'arete entre s1 et s5
 136 c       a2 est l'arete entre s2 et s5
 137 c       a3 est l'arete entre s3 et s5
 138 c       a4 est l'arete entre s4 et s5
 139 c       a5 est l'arete entre s1 et s2
 140 c       a6 est l'arete entre s2 et s3
 141 c       a7 est l'arete entre s3 et s4
 142 c       a8 est l'arete entre s4 et s1
 143 c
 144       data arsopy / 1, 5, 8, 0,   2, 5, 6, 0,   3, 6, 7, 0,
 145      >              4, 7, 8, 0,   1, 2, 3, 4 /
 146 c
 147 c     pour un pentaedre :
 148 c
 149 c       a1 est l'arete entre s1 et s3
 150 c       a2 est l'arete entre s1 et s2
 151 c       a3 est l'arete entre s2 et s3
 152 c       a4 est l'arete entre s4 et s6
 153 c       a5 est l'arete entre s4 et s5
 154 c       a6 est l'arete entre s5 et s6
 155 c       a7 est l'arete entre s1 et s4
 156 c       a8 est l'arete entre s2 et s5
 157 c       a9 est l'arete entre s3 et s6
 158 c
 159       data arsope / 1, 2, 7,   2, 3, 8,   1, 3, 9,    4, 5, 7,
 160      >              5, 6, 8,   4, 6, 9 /
 161 c ______________________________________________________________________
 162 c
 163 c====
 164 c 1. messages
 165 c====
 166 c
 167 #include "impr01.h"
 168 c
 169 #ifdef _DEBUG_HOMARD_
 170       write (ulsort,texte(langue,1)) 'Entree', nompro
 171       call dmflsh (iaux)
 172 #endif
 173 c
 174       texte(1,4) = '(5x,''Controle des '',a)'
 175       texte(1,5) = '(''Il faut au moins 2 aretes dans la liste !'')'
 176       texte(1,6) = '(''Mauvais type de verification (typver) :'',i8)'
 177       texte(1,7) = '(/,a,'' numero'',i8)'
 178       texte(1,8) = '(''Nombre d''''aretes attendues :'',i8)'
 179       texte(1,9) = '(''Nombre d''''aretes fournies  :'',i8)'
 180       texte(1,10) = '(''Les aretes ne se suivent pas :'')'
 181       texte(1,11) = '(''La suite des aretes ne ferme pas :'')'
 182       texte(1,12) = '(''La suite des aretes n''''est pas conforme :'')'
 183       texte(1,20) = '(''Controle impossible'',/)'
 184 c
 185       texte(2,4) = '(5x,''Control of the '',a)'
 186       texte(2,5) = '(''At least 2 edges in the list !'')'
 187       texte(2,6) = '(''Bad choice for checking (typver) :'',i8)'
 188       texte(2,7) = '(/,a,'' #'',i8)'
 189       texte(2,8) = '(''Number of expected edges :'',i8)'
 190       texte(2,9) = '(''Number of given edges    :'',i8)'
 191       texte(2,10) = '(''Edges are not following each other :'')'
 192       texte(2,11) = '(''The list of edges is not closed :'')'
 193       texte(2,12) = '(''The list of edges is not correct :'')'
 194       texte(2,20) = '(''Control cannot be done.'',/)'
 195 c
 196 #ifdef _DEBUG_HOMARD_
 197       write (ulsort,texte(langue,4)) mess14(langue,3,1)
 198 #endif
 199 c
 200       codret = 0
 201 c
 202 c====
 203 c 2. verifications prealables
 204 c====
 205 c
 206 c 2.1. ==> Au moins 2 aretes dans la liste !
 207 c
 208       if ( nbaret.le.1 ) then
 209 c
 210         write (ulsort,texte(langue,4)) mess14(langue,3,1)
 211         write (ulsort,texte(langue,5))
 212         codret = 1
 213 c
 214       else
 215 c
 216 c 2.2. ==> Le bon code de controle
 217 c
 218         if ( typver.lt.-1 .or.
 219      >       typver.eq.1 .or.
 220      >       typver.ge.8 ) then
 221 c
 222           write (ulsort,texte(langue,6)) typver
 223           codret = 2
 224 c
 225 c 2.2. ==> Le bon nombre d'aretes pour un element
 226 c
 227         elseif ( typver.gt.0 ) then
 228 c
 229           if ( nbaret.ne.nbaref(typver) ) then
 230             write (ulsort,texte(langue,7)) mess14(langue,2,typver),
 231      >                                     numele
 232             write (ulsort,texte(langue,8)) nbaref(typver)
 233             write (ulsort,texte(langue,9)) nbaret
 234             codret = 3
 235           endif
 236 c
 237         endif
 238 c
 239       endif
 240 c
 241       if ( codret.ne.0 ) then
 242         write (ulsort,texte(langue,20))
 243         write (ulbila,texte(langue,20))
 244       else
 245 c
 246 c====
 247 c 3. verification pour un tetraedre
 248 c====
 249 c
 250 #ifdef _DEBUG_HOMARD_
 251       if ( typver.ge.3 .and. typver.le.7 ) then
 252         write (ulsort,texte(langue,4)) mess14(langue,3,typver)
 253       endif
 254 #endif
 255 c
 256       if ( typver.eq.3 ) then
 257 c
 258         iaux = 4
 259 #ifdef _DEBUG_HOMARD_
 260       write (ulsort,texte(langue,3)) 'UTVAR1', nompro
 261 #endif
 262         call utvar1 ( iaux, arsote, listar, somare,
 263      >                ulsort, langue, codret )
 264 c
 265 c====
 266 c 4. verification pour un hexaedre
 267 c====
 268 c
 269       elseif ( typver.eq.6 ) then
 270 c
 271         iaux = 8
 272 #ifdef _DEBUG_HOMARD_
 273       write (ulsort,texte(langue,3)) 'UTVAR1', nompro
 274 #endif
 275         call utvar1 ( iaux, arsohe, listar, somare,
 276      >                ulsort, langue, codret )
 277 c
 278 c====
 279 c 5. verification pour une pyramide
 280 c====
 281 c
 282       elseif ( typver.eq.5 ) then
 283 c
 284         do 51 , iaux = 1 , 5
 285 c
 286 c         examen du iaux-eme sommet local
 287 c
 288           kaux = 0
 289           if ( iaux.le.4 ) then
 290             kvoulu = 2
 291           else
 292             kvoulu = 3
 293           endif
 294 c
 295           do 511 , jaux = 1 , 2
 296 c
 297             s1 = somare(jaux,listar(arsopy(1,iaux)))
 298             if ( s1.eq.somare(1,listar(arsopy(2,iaux))) .or.
 299      >           s1.eq.somare(2,listar(arsopy(2,iaux))) ) then
 300               kaux = kaux + 1
 301             endif
 302             if ( s1.eq.somare(1,listar(arsopy(3,iaux))) .or.
 303      >           s1.eq.somare(2,listar(arsopy(3,iaux))) ) then
 304               kaux = kaux + 1
 305             endif
 306             if ( iaux.eq.5 ) then
 307               if ( s1.eq.somare(1,listar(arsopy(4,iaux))) .or.
 308      >             s1.eq.somare(2,listar(arsopy(4,iaux))) ) then
 309                 kaux = kaux + 1
 310               endif
 311             endif
 312 c
 313   511     continue
 314           if ( kaux.ne.kvoulu ) then
 315             codret = 12
 316           endif
 317 c
 318    51   continue
 319 c
 320 c====
 321 c 6. verification pour un pentaedre
 322 c====
 323 c
 324       elseif ( typver.eq.7 ) then
 325 c
 326         iaux = 6
 327 #ifdef _DEBUG_HOMARD_
 328       write (ulsort,texte(langue,3)) 'UTVAR1', nompro
 329 #endif
 330         call utvar1 ( iaux, arsope, listar, somare,
 331      >                ulsort, langue, codret )
 332 c
 333 c====
 334 c 7. verification de continuite pour les autres types d'element
 335 c====
 336 c
 337       else
 338 c
 339 c 7.1. ==> recherche du premier sommet
 340 c
 341         laret1 = listar(1)
 342         laret2 = listar(2)
 343         if ( somare(1,laret1).eq.somare(1,laret2) ) then
 344           lesom1 = somare(2,laret1)
 345           jaux = 2
 346         elseif ( somare(1,laret1).eq.somare(2,laret2) ) then
 347           lesom1 = somare(2,laret1)
 348           jaux = 1
 349         elseif ( somare(2,laret1).eq.somare(1,laret2) ) then
 350           lesom1 = somare(1,laret1)
 351           jaux = 2
 352         elseif ( somare(2,laret1).eq.somare(2,laret2) ) then
 353           lesom1 = somare(1,laret1)
 354           jaux = 1
 355         else
 356           codret = 10
 357         endif
 358 c
 359 c 7.2. ==> poursuite de la liste
 360 c
 361         do 72 , iaux = 3 , nbaret
 362 c
 363           if ( codret.eq.0 ) then
 364 c
 365             laret1 = laret2
 366             laret2 = listar(iaux)
 367 c
 368             if ( somare(jaux,laret1).eq.somare(1,laret2) ) then
 369               jaux = 2
 370             elseif ( somare(jaux,laret1).eq.somare(2,laret2) ) then
 371               jaux = 1
 372             else
 373               codret = 10
 374             endif
 375 c
 376           endif
 377 c
 378    72 continue
 379 c
 380 c 7.3. ==> bouclage
 381 c
 382         if ( typver.ge.0 ) then
 383           if ( lesom1.ne.somare(jaux,laret2) ) then
 384             codret = 11
 385           endif
 386         endif
 387 c
 388       endif
 389 c
 390       endif
 391 cgn      if ( mod(numele,2).eq.0)codret=10
 392 c
 393 c====
 394 c 8. impressions en cas d'erreur
 395 c====
 396 c
 397       if ( codret.ne.0 ) then
 398 c
 399       if ( ulsort.ne.ulbila ) then
 400         jaux = 2
 401       else
 402         jaux = 1
 403       endif
 404 c
 405       do 81 , kaux = 1 , jaux
 406 c
 407         if ( kaux.eq.1 ) then
 408           ulaux = ulsort
 409         else
 410           ulaux = ulbila
 411         endif
 412 c
 413         if ( typver.gt.0 ) then
 414           write (ulaux,texte(langue,7)) mess14(langue,2,typver), numele
 415         endif
 416         if ( codret.ge.10 ) then
 417           write (ulaux,texte(langue,codret))
 418         endif
 419 c
 420         write (ulaux,8000) mess14(langue,2,1),
 421      >                      mess14(langue,2,-1), mess14(langue,2,-1)
 422         do 810 , iaux = 1 , nbaret
 423           laret1 = listar(iaux)
 424           write (ulaux,8001) laret1, somare(1,laret1), somare(2,laret1)
 425   810   continue
 426         write (ulaux,8002)
 427 c
 428    81 continue
 429 c
 430  8000 format(
 431      >/,53('*')
 432      >/,'* ',a14,'* ',a14,'1 * ',a14,'2 *'
 433      >/, 53('*'))
 434  8001 format('*',i10,'     *',2(i10,'       *'))
 435  8002 format(53('*'),/)
 436 c
 437       endif
 438 c
 439 c====
 440 c 9. la fin
 441 c====
 442 c
 443       if ( codret.ne.0 ) then
 444 c
 445 #include "envex2.h"
 446 c
 447       write (ulsort,texte(langue,1)) 'Sortie', nompro
 448       write (ulsort,texte(langue,2)) codret
 449 c
 450       endif
 451 c
 452 #ifdef _DEBUG_HOMARD_
 453       write (ulsort,texte(langue,1)) 'Sortie', nompro
 454       call dmflsh (iaux)
 455 #endif
 456 c
 457       end