src/tool/Decision/deisa1.F

   1       subroutine deisa1 ( nbvent, ncmpin, usacmp,
   2      >                    nosupp, noindi,
   3      >                    arsupp, arindi,
   4      >                    trsupp, trindi,
   5      >                    qusupp, quindi,
   6      >                    tesupp, teindi,
   7      >                    hesupp, heindi,
   8      >                    pysupp, pyindi,
   9      >                    pesupp, peindi,
  10      >                    nharet, nhtria, nhquad,
  11      >                    nhtetr, nhhexa, nhpyra, nhpent,
  12      >                    nomail, nhvois,
  13      >                    ulsort, langue, codret)
  14 c ______________________________________________________________________
  15 c
  16 c                             H O M A R D
  17 c
  18 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  19 c
  20 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  21 c aupres des huissiers de justice Simart et Lavoir a Clamart
  22 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  23 c aupres des huissiers de justice
  24 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  25 c
  26 c    HOMARD est une marque deposee d'Electricite de France
  27 c
  28 c Copyright EDF 1996
  29 c Copyright EDF 1998
  30 c Copyright EDF 2002
  31 c Copyright EDF 2020
  32 c ______________________________________________________________________
  33 c
  34 c traitement des DEcisions - Initialisations - SAut - etape 1
  35 c                --          -                 --           -
  36 c ______________________________________________________________________
  37 c .        .     .        .                                            .
  38 c .  nom   . e/s . taille .           description                      .
  39 c .____________________________________________________________________.
  40 c . nbvent .  e .   -1:7  . nombre d'entites actives pour chaque type  .
  41 c .        .     .        . d'element au sens HOMARD avec indicateur   .
  42 c . ncmpin .  e  .   1    . nombre de composantes de l'indicateur      .
  43 c . usacmp . e   .   1    . usage des composantes de l'indicateur      .
  44 c .        .     .        . 0 : norme L2                               .
  45 c .        .     .        . 1 : norme infinie -max des valeurs absolues.
  46 c .        .     .        . 2 : valeur relative si une seule composante.
  47 c . nosupp . e   . nbnoto . support pour les noeuds                    .
  48 c . noindi . es  . nbnoto . valeurs reelles pour les noeuds            .
  49 c . arsupp .  s  . nbarto . support pour les aretes                    .
  50 c . arindi .  s  . nbarto . valeurs reelles pour les aretes            .
  51 c . trsupp . e   . nbtrto . support pour les triangles                 .
  52 c . trindi .  s  . nbtrto . valeurs pour les triangles                 .
  53 c . qusupp . e   . nbquto . support pour les quadrangles               .
  54 c . quindi .  s  . nbquto . valeurs pour les quadrangles               .
  55 c . tesupp . e   . nbteto . support pour les tetraedres                .
  56 c . teindi .  s  . nbteto . valeurs pour les tetraedres                .
  57 c . hesupp . e   . nbheto . support pour les hexaedres                 .
  58 c . heindi .  s  . nbheto . valeurs pour les hexaedres                 .
  59 c . pysupp . e   . nbpyto . support pour les pyramides                 .
  60 c . pyindi .  s  . nbpyto . valeurs pour les pyramides                 .
  61 c . pesupp . e   . nbpeto . support pour les pentaedres                .
  62 c . peindi .  s  . nbpeto . valeurs pour les pentaedres                .
  63 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  64 c . langue . e   .    1   . langue des messages                        .
  65 c .        .     .        . 1 : francais, 2 : anglais                  .
  66 c . codret . es  .    1   . code de retour des modules                 .
  67 c .        .     .        . 0 : pas de probleme                        .
  68 c .        .     .        . 3 : probleme dans les fichiers             .
  69 c ______________________________________________________________________
  70 c
  71 c====
  72 c 0. declarations et dimensionnement
  73 c====
  74 c
  75 c 0.1. ==> generalites
  76 c
  77       implicit none
  78       save
  79 c
  80       character*6 nompro
  81       parameter ( nompro = 'DEISA1' )
  82 c
  83 #include "nblang.h"
  84 c
  85 c 0.2. ==> communs
  86 c
  87 #include "gmreel.h"
  88 #include "gmenti.h"
  89 c
  90 #include "envex1.h"
  91 c
  92 #include "nombno.h"
  93 #include "nombar.h"
  94 #include "nombtr.h"
  95 #include "nombqu.h"
  96 #include "nombte.h"
  97 #include "nombhe.h"
  98 #include "nombpy.h"
  99 #include "nombpe.h"
 100 c
 101 c 0.3. ==> arguments
 102 c
 103       integer nbvent(-1:7), ncmpin
 104       integer usacmp
 105       integer nosupp(nbnoto)
 106       integer arsupp(nbarto)
 107       integer trsupp(nbtrto)
 108       integer qusupp(nbquto)
 109       integer tesupp(nbteto)
 110       integer hesupp(nbheto)
 111       integer pysupp(nbpyto)
 112       integer pesupp(nbpeto)
 113 c
 114       integer ulsort, langue, codret
 115 c
 116       double precision noindi(nbnoto,ncmpin)
 117       double precision arindi(nbarto,ncmpin)
 118       double precision trindi(nbtrto,ncmpin)
 119       double precision quindi(nbquto,ncmpin)
 120       double precision teindi(nbteto,ncmpin)
 121       double precision heindi(nbheto,ncmpin)
 122       double precision pyindi(nbpyto,ncmpin)
 123       double precision peindi(nbpeto,ncmpin)
 124 c
 125       character*8 nharet, nhtria, nhquad
 126       character*8 nhtetr, nhhexa, nhpyra, nhpent
 127       character*8 nomail, nhvois
 128 c
 129 c 0.4. ==> variables locales
 130 c
 131       integer iaux, jaux, kaux
 132       integer codre1, codre2, codre3, codre4, codre5
 133       integer codre6
 134       integer codre0
 135 c
 136       integer phetar, psomar, pfilar, pmerar
 137       integer ppovos, pvoiso
 138       integer pposif, pfacar
 139       integer phettr, paretr, pfiltr, ppertr
 140       integer phetqu, parequ, pfilqu, pperqu
 141       integer phette, ptrite, pfilte, pperte, adtes2
 142       integer phethe, pquahe, pfilhe, pperhe, adhes2
 143       integer phetpy, pfacpy, pperpy, adpys2
 144       integer phetpe, pfacpe, pperpe
 145       integer adtra1, adtra2
 146       integer adtrte, adtrhe, adtrpy, adtrpe
 147       integer advotr, adpptr
 148       integer advoqu, adppqu
 149 c
 150       character*8 ntrav1, ntrav2
 151       character*8 ntrate, ntrahe, ntrapy, ntrape
 152 c
 153       integer nbmess
 154       parameter ( nbmess = 10 )
 155       character*80 texte(nblang,nbmess)
 156 c
 157 c 0.5. ==> initialisations
 158 c ______________________________________________________________________
 159 c
 160 c====
 161 c 1. initialisations
 162 c====
 163 c
 164 #include "impr01.h"
 165 c
 166 #ifdef _DEBUG_HOMARD_
 167       write (ulsort,texte(langue,1)) 'Entree', nompro
 168       call dmflsh (iaux)
 169 #endif
 170 c
 171 #include "impr03.h"
 172 c
 173 c====
 174 c 2. les tableaux
 175 c====
 176 c
 177 c 2.1. ==> les tableaux de travail
 178 c
 179       if ( codret.eq.0 ) then
 180 c
 181       iaux = max(4*(nbquto+nbtrto), nbarto)
 182       call gmalot ( ntrav1, 'entier  ', iaux, adtra1, codre1 )
 183       iaux = max(2*(nbquto+nbtrto), nbarto, nbnoto)
 184       iaux = iaux * ncmpin
 185       call gmalot ( ntrav2, 'reel    ', iaux, adtra2, codre2 )
 186       iaux = nbteto * ncmpin
 187       call gmalot ( ntrate, 'reel    ', iaux, adtrte, codre3 )
 188       iaux = nbheto * ncmpin
 189       call gmalot ( ntrahe, 'reel    ', iaux, adtrhe, codre4 )
 190       iaux = nbpyto * ncmpin
 191       call gmalot ( ntrapy, 'reel    ', iaux, adtrpy, codre5 )
 192       iaux = nbpeto * ncmpin
 193       call gmalot ( ntrape, 'reel    ', iaux, adtrpe, codre6 )
 194 c
 195       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 196      >               codre6 )
 197       codret = max ( abs(codre0), codret,
 198      >               codre1, codre2, codre3, codre4, codre5,
 199      >               codre6 )
 200 c
 201       endif
 202 c
 203 c 2.2. ==> les tableaux du maillage
 204 #ifdef _DEBUG_HOMARD_
 205       write (ulsort,90002) '2.2. les tableaux ; codret', codret
 206 #endif
 207 c
 208       if ( nbvent(-1).ne.0 .or. nbvent(1).ne.0 .or.
 209      >      nbvent(2).ne.0 .or. nbvent(4).ne.0 ) then
 210 c
 211 #ifdef _DEBUG_HOMARD_
 212       write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
 213 #endif
 214         iaux = 30
 215         call utad02 ( iaux, nharet,
 216      >                phetar, psomar, pfilar, pmerar,
 217      >                  jaux,   jaux,   jaux,
 218      >                  jaux,   jaux,   jaux,
 219      >                  jaux,   jaux,   jaux,
 220      >                ulsort, langue, codret )
 221 c
 222       endif
 223 c
 224       if ( nbvent(2).ne.0 .or. nbvent(3).ne.0 .or.
 225      >     ( nbtrto.gt.0 .and. nbvent(4).ne.0 ) ) then
 226 c
 227 #ifdef _DEBUG_HOMARD_
 228       write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
 229 #endif
 230         iaux = 30
 231         call utad02 ( iaux, nhtria,
 232      >                phettr, paretr, pfiltr, ppertr,
 233      >                  jaux,   jaux,   jaux,
 234      >                  jaux,   jaux,   jaux,
 235      >                  jaux,   jaux,   jaux,
 236      >                ulsort, langue, codret )
 237 c
 238       endif
 239 c
 240       if ( nbvent(4).ne.0 .or. nbvent(6).ne.0 .or.
 241      >     ( nbquto.gt.0 .and. nbvent(2).ne.0 ) ) then
 242 c
 243 #ifdef _DEBUG_HOMARD_
 244       write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
 245 #endif
 246         iaux = 30
 247         call utad02 ( iaux, nhquad,
 248      >                phetqu, parequ, pfilqu, pperqu,
 249      >                  jaux,   jaux,   jaux,
 250      >                  jaux,   jaux,   jaux,
 251      >                  jaux,   jaux,   jaux,
 252      >                ulsort, langue, codret )
 253 c
 254       endif
 255 c
 256       if ( nbvent(3).ne.0 ) then
 257 c
 258 #ifdef _DEBUG_HOMARD_
 259       write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
 260 #endif
 261         iaux = 2*3
 262         if ( nbteca.gt.0 ) then
 263           iaux = iaux*5*17
 264         endif
 265         call utad02 ( iaux, nhtetr,
 266      >                phette, ptrite, pfilte, pperte,
 267      >                  jaux,   jaux,   jaux,
 268      >                  jaux,   jaux, adtes2,
 269      >                  jaux,   jaux,   jaux,
 270      >                ulsort, langue, codret )
 271 c
 272       endif
 273 c
 274       if ( nbvent(5).ne.0 .or.
 275      >     ( nbpyto.gt.0 .and. nbvent(3).ne.0 ) .or.
 276      >     ( nbpyto.gt.0 .and. nbvent(6).ne.0 ) ) then
 277 c
 278 #ifdef _DEBUG_HOMARD_
 279       write (ulsort,texte(langue,3)) 'UTAD02_py', nompro
 280 #endif
 281         iaux = 2
 282         if ( nbpyca.gt.0 ) then
 283           iaux = iaux*5*17
 284         endif
 285         call utad02 ( iaux, nhpyra,
 286      >                phetpy, pfacpy, jaux  , pperpy,
 287      >                  jaux,   jaux,   jaux,
 288      >                  jaux,   jaux, adpys2,
 289      >                  jaux,   jaux,   jaux,
 290      >                ulsort, langue, codret )
 291 c
 292       endif
 293 c
 294       if ( nbvent(6).ne.0 ) then
 295 c
 296 #ifdef _DEBUG_HOMARD_
 297       write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
 298 #endif
 299         iaux = 2*3
 300         if ( nbheco.gt.0 ) then
 301           iaux = iaux*5*17
 302         endif
 303         call utad02 ( iaux, nhhexa,
 304      >                phethe, pquahe, pfilhe, pperhe,
 305      >                  jaux,   jaux,   jaux,
 306      >                  jaux,   jaux, adhes2,
 307      >                  jaux,   jaux,   jaux,
 308      >                ulsort, langue, codret )
 309 c
 310       endif
 311 c
 312       if ( nbvent(7).ne.0 .or.
 313      >     ( nbpeto.gt.0 .and. nbvent(3).ne.0 ) .or.
 314      >     ( nbpeto.gt.0 .and. nbvent(6).ne.0 ) ) then
 315 c
 316 #ifdef _DEBUG_HOMARD_
 317       write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
 318 #endif
 319         iaux = 2
 320         if ( nbpeca.gt.0 ) then
 321           iaux = iaux*5
 322         endif
 323         call utad02 ( iaux, nhpent,
 324      >                phetpe, pfacpe, jaux  , pperpe,
 325      >                  jaux,   jaux,   jaux,
 326      >                  jaux,   jaux,   jaux,
 327      >                  jaux,   jaux,   jaux,
 328      >                ulsort, langue, codret )
 329 c
 330       endif
 331 c
 332 c 2.3. ==> Voisinages
 333 #ifdef _DEBUG_HOMARD_
 334       write (ulsort,90002) '2.3. ==> Voisinages ; codret', codret
 335 #endif
 336 c
 337       if ( nbvent(-1).ne.0 ) then
 338 c
 339         if ( codret.eq.0 ) then
 340 c
 341        iaux = 1
 342        jaux = 0
 343 #ifdef _DEBUG_HOMARD_
 344       write (ulsort,texte(langue,3)) 'UTVOIS', nompro
 345 #endif
 346        call utvois ( nomail, nhvois,
 347      >               iaux, jaux, jaux, jaux,
 348      >               ppovos, pvoiso,
 349      >               kaux, kaux, kaux,
 350      >               ulsort, langue, codret)
 351 c
 352         endif
 353 c
 354       endif
 355 c
 356       if ( codret.eq.0 ) then
 357 c
 358 #ifdef _DEBUG_HOMARD_
 359       write (ulsort,texte(langue,3)) 'UTAD04', nompro
 360 #endif
 361       iaux = 1
 362       if ( nbvent(-1).ne.0 ) then
 363         iaux = iaux*2
 364       endif
 365       if ( nbvent(2).ne.0 .or. nbvent(4).ne.0 ) then
 366         iaux = iaux*3
 367       endif
 368       if ( nbvent(3).ne.0 ) then
 369         iaux = iaux*5
 370         if ( nbpyto.gt.0 .or. nbpeto.gt.0 ) then
 371           iaux = iaux*13
 372         endif
 373       endif
 374       if ( nbvent(6).ne.0 ) then
 375         iaux = iaux*7
 376         if ( nbpyto.gt.0 .or. nbpeto.gt.0 ) then
 377           iaux = iaux*17
 378         endif
 379       endif
 380       call utad04 ( iaux, nhvois,
 381      >              ppovos, pvoiso, pposif, pfacar,
 382      >              advotr, advoqu,
 383      >                jaux,   jaux, adpptr, adppqu,
 384      >                jaux,   jaux,   jaux,
 385      >                jaux,   jaux,   jaux,
 386      >                jaux,   jaux,   jaux,
 387      >                jaux,   jaux,   jaux,
 388      >              ulsort, langue, codret )
 389 c
 390       endif
 391 c
 392 c====
 393 c 3. Operation
 394 c====
 395 #ifdef _DEBUG_HOMARD_
 396       write (ulsort,90002) '3. operation ; codret', codret
 397 #endif
 398 c
 399       if ( codret.eq.0 ) then
 400 c
 401 #ifdef _DEBUG_HOMARD_
 402       write (ulsort,texte(langue,3)) 'DEISA2', nompro
 403 #endif
 404       call deisa2 ( nbvent, ncmpin, usacmp,
 405      >              nosupp, noindi,
 406      >              arsupp, arindi,
 407      >              trsupp, trindi,
 408      >              qusupp, quindi,
 409      >              tesupp, teindi, rmem(adtrte),
 410      >              hesupp, heindi, rmem(adtrhe),
 411      >              pysupp, pyindi, rmem(adtrpy),
 412      >              pesupp, peindi, rmem(adtrpe),
 413      >              imem(phetar), imem(psomar),
 414      >              imem(pfilar), imem(pmerar),
 415      >              imem(phettr), imem(paretr),
 416      >              imem(pfiltr), imem(ppertr),
 417      >              imem(phetqu), imem(parequ),
 418      >              imem(pfilqu), imem(pperqu),
 419      >              imem(phette), imem(ptrite),
 420      >              imem(pperte), imem(adtes2),
 421      >              imem(phethe), imem(pquahe),
 422      >              imem(pfilhe), imem(pperhe), imem(adhes2),
 423      >              imem(pfacpy),
 424      >              imem(pfacpe),
 425      >              imem(pposif), imem(pfacar),
 426      >              imem(advotr), imem(adpptr),
 427      >              imem(advoqu), imem(adppqu),
 428      >              imem(adtra1), rmem(adtra2),
 429      >              ulsort, langue, codret)
 430 c
 431       endif
 432 c
 433 c====
 434 c 4. Menage
 435 c====
 436 #ifdef _DEBUG_HOMARD_
 437       write (ulsort,90002) '4. Menage ; codret', codret
 438 #endif
 439 c
 440       if ( codret.eq.0 ) then
 441 c
 442       call gmlboj ( ntrav1, codre1 )
 443       call gmlboj ( ntrav2, codre2 )
 444       call gmlboj ( ntrate, codre3 )
 445       call gmlboj ( ntrahe, codre4 )
 446       call gmlboj ( ntrapy, codre5 )
 447       call gmlboj ( ntrape, codre6 )
 448 c
 449       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 450      >               codre6 )
 451       codret = max ( abs(codre0), codret,
 452      >               codre1, codre2, codre3, codre4, codre5,
 453      >               codre6 )
 454 c
 455       endif
 456 c
 457 c====
 458 c 5. la fin
 459 c====
 460 c
 461       if ( codret.ne.0 ) then
 462 c
 463 #include "envex2.h"
 464 c
 465       write (ulsort,texte(langue,1)) 'Sortie', nompro
 466       write (ulsort,texte(langue,2)) codret
 467 c
 468       endif
 469 c
 470 #ifdef _DEBUG_HOMARD_
 471       write (ulsort,texte(langue,1)) 'Sortie', nompro
 472       call dmflsh (iaux)
 473 #endif
 474 c
 475       end