src/tool/Utilitaire/utcoma.F

   1       subroutine utcoma ( nomail, optimp,
   2      >                    ulsort, langue, codret )
   3 c ______________________________________________________________________
   4 c
   5 c                             H O M A R D
   6 c
   7 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   8 c
   9 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  10 c aupres des huissiers de justice Simart et Lavoir a Clamart
  11 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  12 c aupres des huissiers de justice
  13 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  14 c
  15 c    HOMARD est une marque deposee d'Electricite de France
  16 c
  17 c Copyright EDF 1996
  18 c Copyright EDF 1998
  19 c Copyright EDF 2002
  20 c Copyright EDF 2020
  21 c ______________________________________________________________________
  22 c
  23 c    UTilitaire - verification de la COnformite du MAillage
  24 c    --                              --            --
  25 c ______________________________________________________________________
  26 c .        .     .        .                                            .
  27 c .  nom   . e/s . taille .           description                      .
  28 c .____________________________________________________________________.
  29 c . nomail . e   .  ch8   . nom de l'objet contenant le maillage       .
  30 c . optimp . e   .   1    . option d'impression des non-conformites :  .
  31 c .        .     .        . 0 : pas d'impression                       .
  32 c .        .     .        . non nul : impression                       .
  33 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  34 c . langue . e   .    1   . langue des messages                        .
  35 c .        .     .        . 1 : francais, 2 : anglais                  .
  36 c . codret . es  .    1   . code de retour des modules                 .
  37 c .        .     .        . 0 : pas de probleme                        .
  38 c .        .     .        . 2 : probleme dans la recherche de tableaux .
  39 c .        .     .        . 11 : pb. de conformite sur les triangles   .
  40 c .        .     .        . 21 : pb. de conformite sur les tetras      .
  41 c ______________________________________________________________________
  42 c
  43 c====
  44 c 0. declarations et dimensionnement
  45 c====
  46 c
  47 c 0.1. ==> generalites
  48 c
  49       implicit none
  50       save
  51 c
  52       character*6 nompro
  53       parameter ( nompro = 'UTCOMA' )
  54 c
  55 #include "nblang.h"
  56 c
  57 c 0.2. ==> communs
  58 c
  59 #include "envex1.h"
  60 c
  61 #include "gmenti.h"
  62 c
  63 #include "envca1.h"
  64 #include "impr02.h"
  65 c
  66 c 0.3. ==> arguments
  67 c
  68       character*8 nomail
  69 c
  70       integer optimp
  71 c
  72       integer ulsort, langue, codret
  73 c
  74 c 0.4. ==> variables locales
  75 c
  76       integer iaux, jaux
  77       integer nbarto, nbtrto, nbquto
  78       integer nbteto, nbheto, nbpyto, nbpeto
  79       integer nbteca, nbheca, nbpyca, nbpeca
  80       integer nbtecf, nbhecf, nbpycf, nbpecf
  81 c
  82       integer psomar, phetar
  83       integer paretr, phettr
  84       integer parequ, phetqu
  85       integer ptrite, phette, pcotrt, parete
  86       integer pquahe, phethe, pcoquh, parehe
  87       integer pfacpy, phetpy, pcofay, parepy
  88       integer pfacpe, phetpe, pcofap, parepe
  89 c
  90       integer codre1, codre2, codre3, codre4, codre5
  91       integer codre6, codre7
  92       integer codre0
  93 c
  94       character*8 norenu
  95       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
  96       character*8 nhtetr, nhhexa, nhpyra, nhpent
  97       character*8 nhelig
  98       character*8 nhvois, nhsupe, nhsups
  99 c
 100       integer nbmess
 101       parameter ( nbmess = 10 )
 102       character*80 texte(nblang,nbmess)
 103 c
 104 c 0.5. ==> initialisations
 105 c ______________________________________________________________________
 106 c
 107 c====
 108 c 1. messages
 109 c====
 110 c
 111 c 1.1. ==> les messages
 112 c
 113 #include "impr01.h"
 114 c
 115 #ifdef _DEBUG_HOMARD_
 116       write (ulsort,texte(langue,1)) 'Entree', nompro
 117       call dmflsh (iaux)
 118 #endif
 119 c
 120       texte(1,4) = '(''Impossible de recuperer les tableaux.'')'
 121       texte(1,5) = '(''Probleme de conformite sur les '',a,''.'')'
 122       texte(1,6) = '(''Le maillage est de type non-conforme.'')'
 123 c
 124       texte(2,4) = '(''Arrays cannot be found.'')'
 125       texte(2,5) = '(a,'' with hanging nodes.'')'
 126       texte(2,6) = '(''Mesh is hanging-node type.'')'
 127 c
 128 #include "impr03.h"
 129 c
 130 c====
 131 c 2. recuperation des pointeurs, initialisations
 132 c====
 133 c
 134 c 2.1. ==> structure generale
 135 c
 136       if ( codret.eq.0 ) then
 137 c
 138       call utnomh ( nomail,
 139      >                sdim,   mdim,
 140      >               degre, maconf, homolo, hierar,
 141      >              rafdef, nbmane, typcca, typsfr, maextr,
 142      >              mailet,
 143      >              norenu,
 144      >              nhnoeu, nhmapo, nharet,
 145      >              nhtria, nhquad,
 146      >              nhtetr, nhhexa, nhpyra, nhpent,
 147      >              nhelig,
 148      >              nhvois, nhsupe, nhsups,
 149      >              ulsort, langue, codret)
 150 c
 151 cgn      write (ulsort,90003) 'structures',
 152 cgn     > nhnoeu, nhmapo, nharet, nhtria, nhquad,
 153 cgn     > nhtetr, nhhexa, nhpyra, nhpent
 154 cgn      call gmprsx(nompro,nhquad)
 155 cgn      call gmprsx(nompro,nhpyra)
 156 cgn      call gmprsx(nompro,nhpyra//'.InfoSupp')
 157       endif
 158 c
 159 c 2.2. ==> le maillage est declare non conforme
 160 c
 161       if ( codret.eq.0 ) then
 162 c
 163       if ( ( maconf.gt.0 ) .or. ( maconf.eq.-2 ) ) then
 164 c
 165         write (ulsort,texte(langue,6))
 166 c
 167       endif
 168 c
 169       endif
 170 c
 171 c====
 172 c 3. analyse
 173 c====
 174 c
 175       if ( maconf.le.2 ) then
 176 c
 177 c 3.1. ==> Recherche des tableaux
 178 c
 179         if ( codret.eq.0 ) then
 180 c
 181         call gmliat ( nharet, 1, nbarto, codre1 )
 182         call gmliat ( nhtria, 1, nbtrto, codre2 )
 183         call gmliat ( nhquad, 1, nbquto, codre3 )
 184         call gmliat ( nhtetr, 1, nbteto, codre4 )
 185         call gmliat ( nhhexa, 1, nbheto, codre5 )
 186         call gmliat ( nhpyra, 1, nbpyto, codre6 )
 187         call gmliat ( nhpent, 1, nbpeto, codre7 )
 188 c
 189         codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 190      >                 codre6, codre7 )
 191         codret = max ( abs(codre0), codret,
 192      >                 codre1, codre2, codre3, codre4, codre5 ,
 193      >                 codre6, codre7 )
 194 c
 195         endif
 196 c
 197         if ( codret.eq.0 ) then
 198 c
 199         call gmliat ( nhtetr, 2, nbteca, codre1 )
 200         call gmliat ( nhhexa, 2, nbheca, codre2 )
 201         call gmliat ( nhpyra, 2, nbpyca, codre3 )
 202         call gmliat ( nhpent, 2, nbpeca, codre4 )
 203 c
 204         codre0 = min ( codre1, codre2, codre3, codre4 )
 205         codret = max ( abs(codre0), codret,
 206      >                 codre1, codre2, codre3, codre4 )
 207 #ifdef _DEBUG_HOMARD_
 208         write (ulsort,90002) 'nbteca, nbheca, nbpyca, nbpeca',
 209      >                        nbteca, nbheca, nbpyca, nbpeca
 210 #endif
 211 c
 212         endif
 213 c
 214         if ( codret.eq.0 ) then
 215 c
 216         iaux = 2
 217 #ifdef _DEBUG_HOMARD_
 218       write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
 219 #endif
 220         call utad02 (   iaux, nharet,
 221      >                phetar, psomar, jaux  , jaux,
 222      >                  jaux,   jaux,   jaux,
 223      >                  jaux,   jaux,   jaux,
 224      >                  jaux,   jaux,   jaux,
 225      >                ulsort, langue, codret )
 226 c
 227         if ( nbtrto.ne.0 ) then
 228 c
 229          iaux = 2
 230 #ifdef _DEBUG_HOMARD_
 231       write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
 232 #endif
 233          call utad02 (   iaux, nhtria,
 234      >                  phettr, paretr, jaux  ,  jaux,
 235      >                    jaux,   jaux,   jaux,
 236      >                    jaux,   jaux,   jaux,
 237      >                    jaux,   jaux,   jaux,
 238      >                  ulsort, langue, codret )
 239 c
 240         endif
 241 c
 242         if ( nbquto.ne.0 ) then
 243 c
 244           iaux = 2
 245 #ifdef _DEBUG_HOMARD_
 246       write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
 247 #endif
 248           call utad02 (   iaux, nhquad,
 249      >                  phetqu, parequ, jaux  ,   jaux,
 250      >                    jaux,   jaux,   jaux,
 251      >                    jaux,   jaux,   jaux,
 252      >                    jaux,   jaux,   jaux,
 253      >                  ulsort, langue, codret )
 254 c
 255         endif
 256 c
 257         if ( nbteto.ne.0 ) then
 258 c
 259           iaux = 26
 260           if ( nbteca.gt.0 ) then
 261             iaux = iaux*31
 262           endif
 263 #ifdef _DEBUG_HOMARD_
 264       write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
 265 #endif
 266           call utad02 (   iaux, nhtetr,
 267      >                  phette, ptrite, jaux  , jaux,
 268      >                    jaux,   jaux,   jaux,
 269      >                    jaux, pcotrt,   jaux,
 270      >                    jaux,   jaux, parete,
 271      >                  ulsort, langue, codret )
 272 c
 273         endif
 274 c
 275         if ( nbheto.ne.0 ) then
 276 c
 277           iaux = 26
 278           if ( nbheca.gt.0 ) then
 279             iaux = iaux*31
 280           endif
 281 #ifdef _DEBUG_HOMARD_
 282       write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
 283 #endif
 284           call utad02 (   iaux, nhhexa,
 285      >                  phethe, pquahe, jaux  , jaux,
 286      >                    jaux,   jaux,   jaux,
 287      >                    jaux, pcoquh,   jaux,
 288      >                    jaux,   jaux, parehe,
 289      >                  ulsort, langue, codret )
 290 c
 291         endif
 292 c
 293         if ( nbpyto.ne.0 ) then
 294 c
 295           iaux = 26
 296           if ( nbpyca.gt.0 ) then
 297             iaux = iaux*31
 298           endif
 299 #ifdef _DEBUG_HOMARD_
 300       write (ulsort,texte(langue,3)) 'UTAD02_py', nompro
 301 #endif
 302           call utad02 (   iaux, nhpyra,
 303      >                  phetpy, pfacpy, jaux  , jaux,
 304      >                    jaux,   jaux,   jaux,
 305      >                    jaux, pcofay,   jaux,
 306      >                    jaux,   jaux, parepy,
 307      >                  ulsort, langue, codret )
 308 c
 309         endif
 310 c
 311         if ( nbpeto.ne.0 ) then
 312 c
 313           iaux = 26
 314           if ( nbpeca.gt.0 ) then
 315             iaux = iaux*31
 316           endif
 317 #ifdef _DEBUG_HOMARD_
 318       write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
 319 #endif
 320           call utad02 (   iaux, nhpent,
 321      >                  phetpe, pfacpe, jaux  , jaux,
 322      >                    jaux,   jaux,   jaux,
 323      >                    jaux, pcofap,   jaux,
 324      >                    jaux,   jaux, parepe,
 325      >                  ulsort, langue, codret )
 326 c
 327         endif
 328 c
 329         endif
 330 c
 331 c 3.2. ==> Analyse
 332 c
 333         if ( codret.eq.0 ) then
 334 c
 335         iaux = maconf
 336 #ifdef _DEBUG_HOMARD_
 337       write (ulsort,texte(langue,3)) 'UTCONF', nompro
 338 #endif
 339         call utconf ( nbarto, nbtrto, nbquto,
 340      >                nbteto, nbheto, nbpyto, nbpeto,
 341      >                nbteca, nbheca, nbpyca, nbpeca,
 342      >                nbtecf, nbhecf, nbpycf, nbpecf,
 343      >                imem(phetar),
 344      >                imem(phettr), imem(paretr),
 345      >                imem(phetqu), imem(parequ),
 346      >                imem(phette), imem(ptrite), imem(pcotrt),
 347      >                imem(phethe), imem(pquahe), imem(pcoquh),
 348      >                imem(phetpy), imem(pfacpy), imem(pcofay),
 349      >                imem(phetpe), imem(pfacpe), imem(pcofap),
 350      >                iaux, optimp,
 351      >                ulsort, langue, codret )
 352 c
 353         endif
 354 c
 355       endif
 356 c
 357 c====
 358 c 4. la fin
 359 c====
 360 c
 361       if ( codret.ne.0 ) then
 362 c
 363 #include "envex2.h"
 364 c
 365         write (ulsort,texte(langue,1)) 'Sortie', nompro
 366         write (ulsort,texte(langue,2)) codret
 367         if ( codret.eq.2 ) then
 368           write (ulsort,texte(langue,4))
 369         else
 370 #ifdef _DEBUG_HOMARD_
 371 c
 372 #else
 373           if ( optimp.ne.0 ) then
 374 #endif
 375             write (ulsort,texte(langue,5)) mess14(langue,3,codret)
 376 #ifdef _DEBUG_HOMARD_
 377 c
 378 #else
 379 c
 380           endif
 381 #endif
 382         endif
 383 c
 384       endif
 385 c
 386 #ifdef _DEBUG_HOMARD_
 387       write (ulsort,texte(langue,1)) 'Sortie', nompro
 388       call dmflsh (iaux)
 389 #endif
 390 c
 391       end