src/tool/Decision/decora.F

   1       subroutine decora ( nomail,
   2      >                    lgopti, taopti, lgopts, taopts,
   3      >                    lgetco, taetco,
   4      >                    afaire,
   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 traitement des DEcisions - COntraintes de RAffinement
  27 c                --          --             --
  28 c ______________________________________________________________________
  29 c .        .     .        .                                            .
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . nomail . e   .  ch8   . nom de l'objet contenant le maillage       .
  33 c . lgopti . e   .   1    . longueur du tableau des options            .
  34 c . taopti . e   . lgopti . tableau des options                        .
  35 c . lgopts . e   .   1    . longueur du tableau des options caracteres .
  36 c . taopts . e   . lgopts . tableau des options caracteres             .
  37 c . lgetco . e   .   1    . longueur du tableau de l'etat courant      .
  38 c . taetco . e   . lgetco . tableau de l'etat courant                  .
  39 c . afaire .   s .    1   . que faire a la sortie                      .
  40 c .        .     .        . 0 : aucune action                          .
  41 c .        .     .        . 1 : refaire une iteration de l'algorithme  .
  42 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  43 c . langue . e   .    1   . langue des messages                        .
  44 c .        .     .        . 1 : francais, 2 : anglais                  .
  45 c . codret . es  .    1   . code de retour des modules                 .
  46 c .        .     .        . 0 : pas de probleme                        .
  47 c .        .     .        . sinon : probleme                           .
  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 = 'DECORA' )
  61 c
  62 #include "nblang.h"
  63 c
  64 c 0.2. ==> communs
  65 c
  66 #include "envex1.h"
  67 c
  68 #include "gmenti.h"
  69 c
  70 #include "nombno.h"
  71 #include "nombar.h"
  72 #include "nombqu.h"
  73 #include "nombtr.h"
  74 #include "nombte.h"
  75 #include "nombhe.h"
  76 #include "envca1.h"
  77 c
  78 c 0.3. ==> arguments
  79 c
  80       character*8 nomail
  81 c
  82       integer lgopti
  83       integer taopti(lgopti)
  84 c
  85       integer lgopts
  86       character*8 taopts(lgopts)
  87 c
  88       integer lgetco
  89       integer taetco(lgetco)
  90 c
  91       integer afaire
  92       integer ulsort, langue, codret
  93 c
  94 c 0.4. ==> variables locales
  95 c
  96       integer nretap, nrsset
  97       integer iaux, jaux
  98 c
  99       integer psomar, phetar, pfilar, pmerar, pposif, pfacar
 100       integer phettr, paretr, pnivtr, advotr
 101       integer phetqu, parequ, pnivqu, advoqu
 102       integer phette, ptrite
 103       integer phethe, pquahe, pcoquh
 104 c
 105       integer pdecar, pdecfa
 106       integer adhoar
 107       integer adtra3, adtra4, adtra5, adtra6
 108 c
 109       integer codre0, codre1, codre2, codre3, codre4
 110 c
 111       character*6 saux
 112       character*8 ntrav1, ntrav2, ntrav3, ntrav4, ntrav5, ntrav6
 113       character*8 norenu
 114       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 115       character*8 nhtetr, nhhexa, nhpyra, nhpent
 116       character*8 nhelig
 117       character*8 nhvois, nhsupe, nhsups
 118 c
 119       integer nbmess
 120       parameter ( nbmess = 10 )
 121       character*80 texte(nblang,nbmess)
 122 c
 123 c 0.5. ==> initialisations
 124 c ______________________________________________________________________
 125 c
 126 c====
 127 c 1. messages
 128 c====
 129 c
 130 #include "impr01.h"
 131 c
 132 #ifdef _DEBUG_HOMARD_
 133       write (ulsort,texte(langue,1)) 'Entree', nompro
 134       call dmflsh (iaux)
 135 #endif
 136 c
 137 c 1.3. ==> les messages
 138 c
 139       texte(1,4) = '(/,a6,'' CONTRAINTES POUR LE RAFFINEMENT'')'
 140       texte(1,5) = '(38(''=''),/)'
 141       texte(1,6) = '(5x,''Toutes les contraintes sont respectees.'')'
 142       texte(1,7) = '(''Option choisie :'',i4)'
 143       texte(1,9) = '(''Cette option est impossible en dimension'',i2,/)'
 144       texte(1,10) = '(''Decision en retour de '',a6,'' ='',i2,/)'
 145 c
 146       texte(2,4) = '(/,a6,'' REFINEMENT CONDITIONS'')'
 147       texte(2,5) = '(28(''=''),/)'
 148       texte(2,6) = '(5x,''No more unfilled conditions.'')'
 149       texte(2,7) = '(''Selected option :'',i4)'
 150       texte(2,9) =
 151      > '(''This option is not available with dimension'',i4,/)'
 152       texte(2,10) = '(''Decision code from '',a6,'' ='',i4,/)'
 153 c
 154 c 1.4. ==> le numero de sous-etape
 155 c
 156       nretap = taetco(1)
 157       nrsset = taetco(2) + 1
 158       taetco(2) = nrsset
 159 c
 160       call utcvne ( nretap, nrsset, saux, iaux, codret )
 161 c
 162 c 1.5. ==> le titre
 163 c
 164       write (ulsort,texte(langue,4)) saux
 165       write (ulsort,texte(langue,5))
 166 c
 167 #include "impr03.h"
 168 c
 169 #ifdef _DEBUG_HOMARD_
 170       write (ulsort,texte(langue,7)) taopti(36)
 171 #endif
 172 c
 173 c====
 174 c 2. recuperation des pointeurs, initialisations
 175 c====
 176 c
 177 c 2.1. ==> structure generale
 178 c
 179       if ( codret.eq.0 ) then
 180 c
 181 #ifdef _DEBUG_HOMARD_
 182       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 183 #endif
 184       call utnomh ( nomail,
 185      >                sdim,   mdim,
 186      >               degre, maconf, homolo, hierar,
 187      >              rafdef, nbmane, typcca, typsfr, maextr,
 188      >              mailet,
 189      >              norenu,
 190      >              nhnoeu, nhmapo, nharet,
 191      >              nhtria, nhquad,
 192      >              nhtetr, nhhexa, nhpyra, nhpent,
 193      >              nhelig,
 194      >              nhvois, nhsupe, nhsups,
 195      >              ulsort, langue, codret)
 196 c
 197       endif
 198 c
 199 c 2.2. ==> tableaux
 200 #ifdef _DEBUG_HOMARD_
 201       write (ulsort,90002) '2.2. tableaux ; codret', codret
 202 #endif
 203 #ifdef _DEBUG_HOMARD_
 204       write (ulsort,90002) 'taopti(36)', taopti(36)
 205 #endif
 206 c
 207       if ( codret.eq.0 ) then
 208 c
 209       if ( mod(taopti(36),2).eq.0 ) then
 210         iaux = 10
 211       elseif ( mod(taopti(36),3).eq.0 ) then
 212         iaux = 2
 213       elseif ( mod(taopti(36),5).eq.0 ) then
 214         iaux = 6
 215       else
 216         codret = 2
 217       endif
 218       if ( homolo.ge.2 ) then
 219         iaux = iaux*29
 220       endif
 221 #ifdef _DEBUG_HOMARD_
 222       write (ulsort,90002) 'iaux, codret', iaux, codret
 223 #endif
 224 c
 225 #ifdef _DEBUG_HOMARD_
 226       write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
 227 #endif
 228       call utad02 ( iaux, nharet,
 229      >              phetar, psomar, pfilar, pmerar,
 230      >                jaux,   jaux,   jaux,
 231      >                jaux,   jaux,   jaux,
 232      >                jaux, adhoar,   jaux,
 233      >              ulsort, langue, codret )
 234 c
 235       if ( nbtrto.ne.0 ) then
 236 c
 237         if ( mod(taopti(36),2).eq.0 ) then
 238           iaux = 22
 239         else
 240           iaux = 2
 241         endif
 242 #ifdef _DEBUG_HOMARD_
 243       write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
 244 #endif
 245         call utad02 ( iaux, nhtria,
 246      >                phettr, paretr, jaux  , jaux  ,
 247      >                  jaux,   jaux,   jaux,
 248      >                pnivtr,   jaux,   jaux,
 249      >                  jaux,   jaux,   jaux,
 250      >                ulsort, langue, codret )
 251 c
 252       endif
 253 c
 254       if ( nbquto.ne.0 ) then
 255 c
 256         if ( mod(taopti(36),2).eq.0 ) then
 257           iaux = 22
 258         else
 259           iaux = 2
 260         endif
 261 #ifdef _DEBUG_HOMARD_
 262       write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
 263 #endif
 264         call utad02 ( iaux, nhquad,
 265      >                phetqu, parequ, jaux  , jaux  ,
 266      >                  jaux,   jaux,   jaux,
 267      >                pnivqu,   jaux,   jaux,
 268      >                  jaux,   jaux,   jaux,
 269      >                ulsort, langue, codret )
 270 c
 271       endif
 272 c
 273       if ( nbteto.ne.0 ) then
 274 c
 275         if ( mod(taopti(36),5).eq.0 ) then
 276           iaux = 2
 277 #ifdef _DEBUG_HOMARD_
 278       write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
 279 #endif
 280           call utad02 ( iaux, nhtetr,
 281      >                  phette, ptrite, jaux  , jaux  ,
 282      >                  jaux,   jaux,   jaux,
 283      >                  jaux,   jaux,   jaux,
 284      >                  jaux,   jaux,   jaux,
 285      >                  ulsort, langue, codret )
 286         endif
 287 c
 288       endif
 289 c
 290       if ( nbheto.ne.0 ) then
 291 c
 292         if ( mod(taopti(36),5).eq.0 ) then
 293           iaux = 26
 294 #ifdef _DEBUG_HOMARD_
 295       write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
 296 #endif
 297           call utad02 ( iaux, nhhexa,
 298      >                  phethe, pquahe, jaux  , jaux  ,
 299      >                    jaux,   jaux,   jaux,
 300      >                    jaux, pcoquh,   jaux,
 301      >                    jaux,   jaux,   jaux,
 302      >                  ulsort, langue, codret )
 303         endif
 304 c
 305       endif
 306 c
 307 c 2.3. ==> voisinages
 308 c
 309 #ifdef _DEBUG_HOMARD_
 310       write (ulsort,90002) '2.3. voisinages ; codret', codret
 311 #endif
 312 c
 313       if ( codret.eq.0 ) then
 314 c
 315       iaux = 3
 316       if ( mod(taopti(36),2).eq.0 .or.
 317      >     mod(taopti(36),5).eq.0 ) then
 318         if ( nbteto.ne.0 ) then
 319           iaux = iaux*5
 320         endif
 321         if ( nbheto.ne.0 ) then
 322           iaux = iaux*7
 323         endif
 324       endif
 325 #ifdef _DEBUG_HOMARD_
 326       write (ulsort,texte(langue,3)) 'UTAD04', nompro
 327 #endif
 328       call utad04 ( iaux, nhvois,
 329      >                jaux,   jaux, pposif, pfacar,
 330      >              advotr, advoqu,
 331      >                jaux,   jaux,   jaux,   jaux,
 332      >                jaux,   jaux,   jaux,
 333      >                jaux,   jaux,   jaux,
 334      >                jaux,   jaux,   jaux,
 335      >                jaux,   jaux,   jaux,
 336      >              ulsort, langue, codret )
 337 c
 338       endif
 339 c
 340 c 2.4. ==> decisions
 341 c
 342 #ifdef _DEBUG_HOMARD_
 343       write (ulsort,90002) '2.4. decisions ; codret', codret
 344 #endif
 345 c
 346       ntrav1 = taopts(11)
 347       call gmadoj ( ntrav1, pdecar, iaux, codre1 )
 348       ntrav2 = taopts(12)
 349       call gmadoj ( ntrav2, pdecfa, iaux, codre2 )
 350 c
 351       codre0 = min ( codre1, codre2 )
 352       codret = max ( abs(codre0), codret,
 353      >               codre1, codre2 )
 354 c
 355 c 2.5. ==> auxiliaires
 356 c
 357 #ifdef _DEBUG_HOMARD_
 358       write (ulsort,90002) '2.5. auxiliaires ; codret', codret
 359 #endif
 360 c
 361       iaux = 2 * ( nbtrto + nbquto )
 362       call gmalot ( ntrav3, 'entier', iaux, adtra3, codre1 )
 363       iaux = nbnoto
 364       call gmalot ( ntrav4, 'entier', iaux, adtra4, codre2 )
 365       iaux = nbarto
 366       call gmalot ( ntrav5, 'entier', iaux, adtra5, codre3 )
 367       iaux = nbtrto + nbquto
 368       call gmalot ( ntrav6, 'entier', iaux, adtra6, codre4 )
 369 c
 370       codre0 = min ( codre1, codre2, codre3, codre4 )
 371       codret = max ( abs(codre0), codret,
 372      >               codre1, codre2, codre3, codre4 )
 373 c
 374       endif
 375 c
 376 c====
 377 c 3. Application des contraintes
 378 c====
 379 #ifdef _DEBUG_HOMARD_
 380       write (ulsort,90002) '3. Application contraintes ; codret', codret
 381 #endif
 382 c
 383       if ( codret.eq.0 ) then
 384 c
 385         afaire = 0
 386 c
 387 c 3.1. ==> Decalage de deux elements avant un changement de niveau
 388 c          operationnel en 2D uniquement aujourd'hui
 389 c
 390         if ( mod(taopti(36),2).eq.0 ) then
 391 c
 392           if ( sdim.ne.2 ) then
 393 c
 394             write (ulsort,texte(langue,7)) taopti(36)
 395             write (ulsort,texte(langue,9)) sdim
 396             codret = 3
 397 c
 398           else
 399 c
 400 #ifdef _DEBUG_HOMARD_
 401           write (ulsort,texte(langue,3)) 'DECR02', nompro
 402 #endif
 403           call decr02 ( imem(pdecfa), imem(pdecar),
 404      >                  imem(psomar),
 405      >                  imem(pfilar), imem(pmerar), imem(phetar),
 406      >                  imem(pposif), imem(pfacar),
 407      >                  imem(phettr), imem(paretr), imem(pnivtr),
 408      >                  imem(advotr),
 409      >                  imem(phetqu), imem(parequ), imem(pnivqu),
 410      >                  imem(adtra3), imem(adtra4),
 411      >                  imem(adtra5), imem(adtra6),
 412      >                  afaire,
 413      >                  ulsort, langue, codret )
 414 c
 415 #ifdef _DEBUG_HOMARD_
 416           write (ulsort,texte(langue,10)) 'DECR02', afaire
 417 #endif
 418           endif
 419 c
 420         endif
 421 c
 422 c 3.2. ==> Bande de raffinement interdite
 423 c          operationnel en 2D uniquement aujourd'hui
 424 c
 425         if ( mod(taopti(36),3).eq.0 ) then
 426 c
 427           if ( sdim.ne.2 ) then
 428 c
 429             write (ulsort,texte(langue,7)) taopti(36)
 430             write (ulsort,texte(langue,9)) sdim
 431             codret = 3
 432 c
 433           else
 434 c
 435 #ifdef _DEBUG_HOMARD_
 436           write (ulsort,texte(langue,3)) 'DECR03', nompro
 437 #endif
 438           call decr03 ( imem(pdecfa), imem(pdecar),
 439      >                  imem(phetar), imem(pposif), imem(pfacar),
 440      >                  imem(phettr), imem(paretr),
 441      >                  imem(phetqu), imem(parequ),
 442      >                  imem(adtra3),
 443      >                  afaire,
 444      >                  ulsort, langue, codret )
 445 c
 446 #ifdef _DEBUG_HOMARD_
 447           write (ulsort,texte(langue,10)) 'DECR03', afaire
 448 #endif
 449           endif
 450 c
 451         endif
 452 c
 453 c 3.3. ==> Pas d'elements decoupes seul :
 454 c          . Pas de segments sans la ou les faces auxquelles
 455 c            il appartient
 456 c          . Pas de face sans le ou les volumes auxquels il appartient
 457 c
 458         if ( mod(taopti(36),5).eq.0 ) then
 459 c
 460 #ifdef _DEBUG_HOMARD_
 461           write (ulsort,texte(langue,3)) 'DECR05', nompro
 462 #endif
 463           call decr05 ( taopti(31), homolo,
 464      >                  imem(pdecfa), imem(pdecar),
 465      >                  imem(phetar), imem(pfilar),
 466      >                  imem(pposif), imem(pfacar),
 467      >                  imem(phettr), imem(paretr), imem(advotr),
 468      >                  imem(phetqu), imem(parequ), imem(advoqu),
 469      >                  imem(ptrite),
 470      >                  imem(pquahe), imem(pcoquh),
 471      >                  imem(adhoar),
 472      >                  afaire,
 473      >                  ulsort, langue, codret )
 474 c
 475 #ifdef _DEBUG_HOMARD_
 476           write (ulsort,texte(langue,10)) 'DECR05', afaire
 477 #endif
 478 c
 479         endif
 480 c
 481       endif
 482 c
 483 c====
 484 c 4. menage
 485 c====
 486 c
 487       if ( codret.eq.0 ) then
 488 c
 489       call gmlboj ( ntrav3, codre1 )
 490       call gmlboj ( ntrav4, codre2 )
 491       call gmlboj ( ntrav5, codre3 )
 492       call gmlboj ( ntrav6, codre4 )
 493 c
 494       codre0 = min ( codre1, codre2, codre3, codre4 )
 495       codret = max ( abs(codre0), codret,
 496      >               codre1, codre2, codre3, codre4 )
 497 c
 498       endif
 499 c
 500 c====
 501 c 5. la fin
 502 c====
 503 c
 504       if ( codret.eq.0 ) then
 505       if ( afaire.eq.0 ) then
 506         write (ulsort,texte(langue,6))
 507       endif
 508       endif
 509 c
 510       if ( codret.ne.0 ) then
 511 c
 512 #include "envex2.h"
 513 c
 514       write (ulsort,texte(langue,1)) 'Sortie', nompro
 515       write (ulsort,texte(langue,2)) codret
 516 c
 517       endif
 518 c
 519 #ifdef _DEBUG_HOMARD_
 520       write (ulsort,texte(langue,1)) 'Sortie', nompro
 521       call dmflsh (iaux)
 522 #endif
 523 c
 524       end