src/tool/Modification/mmdeg0.F

   1       subroutine mmdeg0 ( nomail,
   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  Modification de Maillage - DEGre - phase 0
  24 c  -               -          ---           -
  25 c ______________________________________________________________________
  26 c .        .     .        .                                            .
  27 c .  nom   . e/s . taille .           description                      .
  28 c .____________________________________________________________________.
  29 c . nomail . e   . char8  . nom de l'objet maillage homard iter. n     .
  30 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  31 c . langue . e   .    1   . langue des messages                        .
  32 c .        .     .        . 1 : francais, 2 : anglais                  .
  33 c . codret . es  .    1   . code de retour des modules                 .
  34 c .        .     .        . 0 : pas de probleme                        .
  35 c .        .     .        . 1 : probleme                               .
  36 c ______________________________________________________________________
  37 c
  38 c====
  39 c 0. declarations et dimensionnement
  40 c====
  41 c
  42 c 0.1. ==> generalites
  43 c
  44       implicit none
  45       save
  46 c
  47       character*6 nompro
  48       parameter ( nompro = 'MMDEG0' )
  49 c
  50 #include "nblang.h"
  51 c
  52 c 0.2. ==> communs
  53 c
  54 #include "envex1.h"
  55 c
  56 #include "gmenti.h"
  57 c
  58 #include "envca1.h"
  59 c
  60 #include "nombar.h"
  61 #include "nombno.h"
  62 #include "nouvnb.h"
  63 c
  64 c 0.3. ==> arguments
  65 c
  66       character*8 nomail
  67 c
  68       integer ulsort, langue, codret
  69 c
  70 c 0.4. ==> variables locales
  71 c
  72       integer iaux
  73       integer codre1, codre2, codre3, codre4, codre5
  74       integer codre6, codre7
  75       integer codre0
  76 c
  77       integer indnoe
  78       integer degnou
  79       integer nbsegm, nbtria, nbquad, nbtetr, nbhexa, nbpyra, nbpent
  80       integer nbfare, pcfaar
  81       integer nbftri, pcfatr
  82       integer nbfqua, pcfaqu
  83       integer nbftet, pcfate
  84       integer nbfhex, pcfahe
  85       integer nbfpyr, pcfapy
  86       integer nbfpen, pcfape
  87       integer adnbrn
  88 c
  89       character*8 norenu
  90       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
  91       character*8 nhtetr, nhhexa, nhpyra, nhpent
  92       character*8 nhelig
  93       character*8 nhvois, nhsupe, nhsups
  94       character*8 nharfa, nhtrfa, nhqufa
  95       character*8 nhtefa, nhhefa, nhpyfa, nhpefa
  96 c
  97       integer nbmess
  98       parameter ( nbmess = 10 )
  99       character*80 texte(nblang,nbmess)
 100 c
 101 c 0.5. ==> initialisations
 102 c ______________________________________________________________________
 103 c
 104 c====
 105 c 1. messages
 106 c====
 107 c
 108 c 1.1. ==> les messages
 109 c
 110 #include "impr01.h"
 111 c
 112 #ifdef _DEBUG_HOMARD_
 113       write (ulsort,texte(langue,1)) 'Entree', nompro
 114       call dmflsh (iaux)
 115 #endif
 116 c
 117       texte(1,4) = '(5x,''Passage du degre '',i1,'' au degre '',i1,/)'
 118 c
 119       texte(2,4) = '(5x,''From degree '',i1,'' to '',i1,/)'
 120 c
 121 c====
 122 c 2. structure de donnees
 123 c====
 124 c
 125 c 2.1. ==> structure generale
 126 c
 127       if ( codret.eq.0 ) then
 128 c
 129 #ifdef _DEBUG_HOMARD_
 130       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 131 #endif
 132 c
 133       call utnomh ( nomail,
 134      >                sdim,   mdim,
 135      >               degre, maconf, homolo, hierar,
 136      >              rafdef, nbmane, typcca, typsfr, maextr,
 137      >              mailet,
 138      >              norenu,
 139      >              nhnoeu, nhmapo, nharet,
 140      >              nhtria, nhquad,
 141      >              nhtetr, nhhexa, nhpyra, nhpent,
 142      >              nhelig,
 143      >              nhvois, nhsupe, nhsups,
 144      >              ulsort, langue, codret)
 145 c
 146       endif
 147 cgn      call gmprsx (nompro, nomail )
 148 cgn      call gmprsx (nompro, nomail//'.Volume' )
 149 cgn      call gmprsx (nompro, nomail//'.Volume.HOM_Te04' )
 150 cgn      call gmprsx (nompro, nharet//'.Famille' )
 151 cgn      call gmprsx (nompro, nhtria//'.Famille' )
 152 cgn      call gmprsx (nompro, nhquad//'.Famille' )
 153 cgn      call gmprsx (nompro, nhtetr//'.Famille' )
 154 cgn      call gmprsx(nompro,nhtetr//'.Famille')
 155 c
 156 c 2.2. ==> grandeurs
 157 c
 158       if ( codret.eq.0 ) then
 159 c
 160       if ( degre.eq.1 ) then
 161 c
 162         degnou = 2
 163         nouvar = nbarto
 164         nouvno = nbnoto + nbarto
 165         indnoe = nbnoto
 166 c
 167       else
 168 c
 169         degnou = 1
 170         nouvno = nbnoto
 171 c
 172       endif
 173 c
 174       write (ulsort,texte(langue,4)) degre, degnou
 175 c
 176       endif
 177 c
 178 c====
 179 c 3. changement de degre pour les noeuds
 180 c====
 181 #ifdef _DEBUG_HOMARD_
 182       write (ulsort,*) '3. chang. de degre noeuds; codret = ', codret
 183 #endif
 184 c
 185       if ( codret.eq.0 ) then
 186 c
 187 c 3.1. ==> Creation des noeuds P2
 188 c
 189       if ( degre.eq.1 ) then
 190 c
 191 #ifdef _DEBUG_HOMARD_
 192       write (ulsort,texte(langue,3)) 'MMCNP2', nompro
 193 #endif
 194 c
 195         call mmcnp2 ( nomail, nhnoeu, nharet,
 196      >                indnoe,
 197      >                ulsort, langue, codret )
 198 c
 199 c 3.2. ==> Suppression des noeuds P2
 200 c
 201       else
 202 c
 203 #ifdef _DEBUG_HOMARD_
 204       write (ulsort,texte(langue,3)) 'MMSNP2', nompro
 205 #endif
 206 c
 207         call mmsnp2 ( nomail,
 208      >                indnoe,
 209      >                ulsort, langue, codret )
 210 c
 211       endif
 212 c
 213       endif
 214 c
 215 c====
 216 c 4. changement de degre pour les elements
 217 c    les elements etant decrits par connectivite descendante, celle-ci
 218 c    est invariante par un changement de degre. Il suffit de changer la
 219 c    localisation de la branche.
 220 c====
 221 #ifdef _DEBUG_HOMARD_
 222       write (ulsort,*) '4.  chang. de degre elem ; codret = ', codret
 223 #endif
 224 c
 225       if ( codret.eq.0 ) then
 226 c
 227       if ( degre.eq.1 ) then
 228 c
 229         call gmcpgp ( nharet, nomail//'.Arete.HOM_Se03' , codre1 )
 230         call gmcpgp ( nhtria, nomail//'.Face.HOM_Tr06'  , codre2 )
 231         call gmcpgp ( nhquad, nomail//'.Face.HOM_Qu08'  , codre3 )
 232         call gmcpgp ( nhtetr, nomail//'.Volume.HOM_Te10', codre4 )
 233         call gmcpgp ( nhpyra, nomail//'.Volume.HOM_Py13', codre5 )
 234         call gmcpgp ( nhhexa, nomail//'.Volume.HOM_He20', codre6 )
 235         call gmcpgp ( nhpent, nomail//'.Volume.HOM_Pe15', codre7 )
 236 c
 237       else
 238 c
 239         call gmcpgp ( nharet, nomail//'.Arete.HOM_Se02' , codre1 )
 240         call gmcpgp ( nhtria, nomail//'.Face.HOM_Tr03'  , codre2 )
 241         call gmcpgp ( nhquad, nomail//'.Face.HOM_Qu04'  , codre3 )
 242         call gmcpgp ( nhtetr, nomail//'.Volume.HOM_Te04', codre4 )
 243         call gmcpgp ( nhpyra, nomail//'.Volume.HOM_Py05', codre5 )
 244         call gmcpgp ( nhhexa, nomail//'.Volume.HOM_He08', codre6 )
 245         call gmcpgp ( nhpent, nomail//'.Volume.HOM_Pe06', codre7 )
 246 c
 247       endif
 248 c
 249       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 250      >               codre6, codre7 )
 251       codret = max ( abs(codre0), codret,
 252      >               codre1, codre2, codre3, codre4, codre5,
 253      >               codre6, codre7 )
 254 c
 255       endif
 256 c
 257       if ( codret.eq.0 ) then
 258 c
 259       call gmlboj ( nharet, codre1 )
 260       call gmlboj ( nhtria, codre2 )
 261       call gmlboj ( nhquad, codre3 )
 262       call gmlboj ( nhtetr, codre4 )
 263       call gmlboj ( nhpyra, codre5 )
 264       call gmlboj ( nhhexa, codre6 )
 265       call gmlboj ( nhpent, codre7 )
 266 c
 267       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 268      >               codre6, codre7 )
 269       codret = max ( abs(codre0), codret,
 270      >               codre1, codre2, codre3, codre4, codre5,
 271      >               codre6, codre7 )
 272 c
 273       endif
 274 c
 275 c====
 276 c 5. mise a jour des grandeurs caracteristiques
 277 c====
 278 #ifdef _DEBUG_HOMARD_
 279       write (ulsort,*) '5. mise a jour ; codret = ', codret
 280 #endif
 281 c
 282 c 5.1. ==> nbmane : nombre maximal de noeud par element
 283 c
 284       if ( codret.eq.0 ) then
 285 c
 286       call gmadoj ( norenu//'.Nombres', adnbrn, iaux, codret )
 287 c
 288       endif
 289 c
 290       if ( codret.eq.0 ) then
 291 c
 292 #ifdef _DEBUG_HOMARD_
 293       write (ulsort,texte(langue,3)) 'UTNBMH', nompro
 294 #endif
 295       call utnbmh ( imem(adnbrn),
 296      >                iaux,   iaux,   iaux,
 297      >                iaux,   iaux,   iaux,
 298      >                iaux,   iaux,   iaux,
 299      >                iaux,   iaux,   iaux,   iaux,
 300      >                iaux, nbsegm, nbtria, nbtetr,
 301      >              nbquad, nbhexa, nbpent, nbpyra,
 302      >                iaux,   iaux,
 303      >                iaux,   iaux,
 304      >              ulsort, langue, codret )
 305 cgn      print *, nbmane
 306 cgn      print *, nbsegm, nbtria, nbquad, nbtetr, nbhexa, nbpent
 307 c
 308       if ( degnou.eq.1 ) then
 309 c
 310         if ( nbhexa.gt.0 ) then
 311           nbmane = 8
 312         elseif ( nbpent.gt.0 ) then
 313           nbmane = 6
 314         elseif ( nbpyra.gt.0 ) then
 315           nbmane = 5
 316         elseif ( nbtetr.gt.0 .or. nbquad.gt.0 ) then
 317           nbmane = 4
 318         elseif ( nbtria.gt.0 ) then
 319           nbmane = 3
 320         elseif ( nbsegm.gt.0 ) then
 321           nbmane = 2
 322         else
 323           nbmane = 1
 324         endif
 325 c
 326       else
 327 c
 328         if ( nbhexa.gt.0 ) then
 329           nbmane = 20
 330         elseif ( nbpent.gt.0 ) then
 331           nbmane = 15
 332         elseif ( nbpyra.gt.0 ) then
 333           nbmane = 13
 334         elseif ( nbtetr.gt.0 ) then
 335           nbmane = 10
 336         elseif ( nbquad.gt.0 ) then
 337           nbmane = 8
 338         elseif ( nbtria.gt.0 ) then
 339           nbmane = 6
 340         elseif ( nbsegm.gt.0 ) then
 341           nbmane = 3
 342         else
 343           nbmane = 1
 344         endif
 345 c
 346       endif
 347 c
 348 cgn      print *, nbmane
 349       call gmecat ( nomail, 8, nbmane , codret )
 350 c
 351       endif
 352 c
 353 c 5.2. ==> le nombres d'entites
 354 #ifdef _DEBUG_HOMARD_
 355       write (ulsort,*) '5.2. nombre entites ; codret = ', codret
 356 #endif
 357 c
 358       if ( codret.eq.0 ) then
 359 c
 360       nbnop2 = nbarto - nbnop2
 361       nbnoto = indnoe
 362       degre = degnou
 363 c
 364       call gmecat ( nhnoeu, 1, nbnoto, codre1 )
 365       call gmecat ( nomail, 3, degre , codre2 )
 366 c
 367       codre0 = min ( codre1, codre2 )
 368       codret = max ( abs(codre0), codret,
 369      >               codre1, codre2 )
 370 c
 371       endif
 372 c
 373 c 5.3. ==> reperage des tableaux des types d'elements
 374 c          attention, il faut refaire un appel a utnomh, car les
 375 c          branches ont ete permutees entre degres ...
 376 #ifdef _DEBUG_HOMARD_
 377       write (ulsort,*) '5.3. reperage ; codret = ', codret
 378 #endif
 379 c
 380       if ( codret.eq.0 ) then
 381 c
 382 c      call gmprsx (nompro,nomail)
 383 c      call gmprsx (nompro,nomail//'.Volume')
 384 c
 385 #ifdef _DEBUG_HOMARD_
 386       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 387 #endif
 388       call utnomh ( nomail,
 389      >                sdim,   mdim,
 390      >               degre, maconf, homolo, hierar,
 391      >              rafdef, nbmane, typcca, typsfr, maextr,
 392      >              mailet,
 393      >              norenu,
 394      >              nhnoeu, nhmapo, nharet,
 395      >              nhtria, nhquad,
 396      >              nhtetr, nhhexa, nhpyra, nhpent,
 397      >              nhelig,
 398      >              nhvois, nhsupe, nhsups,
 399      >              ulsort, langue, codret)
 400 c
 401       endif
 402 c
 403       if ( codret.eq.0 ) then
 404 c
 405       call gmnomc ( nharet//'.Famille', nharfa, codre1 )
 406       call gmnomc ( nhtria//'.Famille', nhtrfa, codre2 )
 407       call gmnomc ( nhquad//'.Famille', nhqufa, codre3 )
 408       call gmnomc ( nhtetr//'.Famille', nhtefa, codre4 )
 409       call gmnomc ( nhhexa//'.Famille', nhhefa, codre5 )
 410       call gmnomc ( nhpyra//'.Famille', nhpyfa, codre6 )
 411       call gmnomc ( nhpent//'.Famille', nhpefa, codre7 )
 412 c
 413       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 414      >               codre6, codre7 )
 415       codret = max ( abs(codre0), codret,
 416      >               codre1, codre2, codre3, codre4, codre5,
 417      >               codre6, codre7 )
 418 c
 419       endif
 420 c
 421       if ( codret.eq.0 ) then
 422 c
 423       call gmliat ( nharfa, 1, nbfare, codre1 )
 424       call gmliat ( nhtrfa, 1, nbftri, codre2 )
 425       call gmliat ( nhqufa, 1, nbfqua, codre3 )
 426       call gmliat ( nhtefa, 1, nbftet, codre4 )
 427       call gmliat ( nhpyfa, 1, nbfpyr, codre5 )
 428       call gmliat ( nhhefa, 1, nbfhex, codre6 )
 429       call gmliat ( nhpefa, 1, nbfpen, codre7 )
 430 c
 431       codre0 = min ( codre1, codre2, codre3, codre4 , codre5,
 432      >               codre6, codre7 )
 433       codret = max ( abs(codre0), codret,
 434      >               codre1, codre2, codre3, codre4, codre5,
 435      >               codre6, codre7 )
 436 c
 437       endif
 438 c
 439       if ( codret.eq.0 ) then
 440 c
 441       call gmadoj ( nharfa//'.Codes'   , pcfaar, iaux, codre1 )
 442       call gmadoj ( nhtrfa//'.Codes'   , pcfatr, iaux, codre2 )
 443       call gmadoj ( nhqufa//'.Codes'   , pcfaqu, iaux, codre3 )
 444       call gmadoj ( nhtefa//'.Codes'   , pcfate, iaux, codre4 )
 445       call gmadoj ( nhpyfa//'.Codes'   , pcfapy, iaux, codre5 )
 446       call gmadoj ( nhhefa//'.Codes'   , pcfahe, iaux, codre6 )
 447       call gmadoj ( nhpefa//'.Codes'   , pcfape, iaux, codre7 )
 448 c
 449       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 450      >               codre6, codre7 )
 451       codret = max ( abs(codre0), codret,
 452      >               codre1, codre2, codre3, codre4, codre5,
 453      >               codre6, codre7 )
 454 c
 455       endif
 456 c
 457 c 5.4. ==> on echange le code du second champ de la description des
 458 c          familles : c'est celui qui designe le type de l'element
 459 #ifdef _DEBUG_HOMARD_
 460       write (ulsort,*) '5.4. echange de code ; codret = ', codret
 461 #endif
 462 c
 463       if ( codret.eq.0 ) then
 464 c
 465 #ifdef _DEBUG_HOMARD_
 466       write (ulsort,*) 'Avant appel a mmelde, codes des familles : '
 467       call gmprsx (nompro, nharfa//'.Codes' )
 468       call gmprsx (nompro, nhtrfa//'.Codes' )
 469       call gmprsx (nompro, nhqufa//'.Codes' )
 470       call gmprsx (nompro, nhtefa//'.Codes' )
 471       call gmprsx (nompro, nhpyfa//'.Codes' )
 472       call gmprsx (nompro, nhhefa//'.Codes' )
 473       call gmprsx (nompro, nhpefa//'.Codes' )
 474 #endif
 475 c
 476 #ifdef _DEBUG_HOMARD_
 477       write (ulsort,texte(langue,3)) 'MMELDE', nompro
 478 #endif
 479       call mmelde ( typcca,
 480      >              nbfare, imem(pcfaar),
 481      >              nbftri, imem(pcfatr),
 482      >              nbfqua, imem(pcfaqu),
 483      >              nbftet, imem(pcfate),
 484      >              nbfhex, imem(pcfahe),
 485      >              nbfpyr, imem(pcfapy),
 486      >              nbfpen, imem(pcfape),
 487      >              ulsort, langue, codret )
 488 c
 489 #ifdef _DEBUG_HOMARD_
 490       write (ulsort,*) 'Apres appel a mmelde, codes des familles : '
 491       call gmprsx (nompro, nharfa//'.Codes'    )
 492       call gmprsx (nompro, nhtrfa//'.Codes'    )
 493       call gmprsx (nompro, nhqufa//'.Codes'    )
 494       call gmprsx (nompro, nhtefa//'.Codes'    )
 495       call gmprsx (nompro, nhpyfa//'.Codes' )
 496       call gmprsx (nompro, nhhefa//'.Codes' )
 497       call gmprsx (nompro, nhpefa//'.Codes' )
 498 #endif
 499 c
 500       endif
 501 c
 502 c====
 503 c 6. suppression des voisins par noeuds s'ils existent
 504 c====
 505 #ifdef _DEBUG_HOMARD_
 506       write (ulsort,*) '6. voisins ; codret = ', codret
 507 #endif
 508 c
 509       if ( codret.eq.0 ) then
 510 c
 511       call gmobal ( nhvois//'.0D/1D', codre0 )
 512 c
 513       if ( codre0.eq.1 ) then
 514 c
 515         call gmlboj ( nhvois//'.0D/1D', codret )
 516 c
 517       elseif ( codre0.ne.0 ) then
 518 c
 519         codret = 5
 520 c
 521       endif
 522 c
 523       endif
 524 c
 525 c====
 526 c 7. la fin
 527 c====
 528 c
 529       if ( codret.ne.0 ) then
 530 c
 531 #include "envex2.h"
 532 c
 533       write (ulsort,texte(langue,1)) 'Sortie', nompro
 534       write (ulsort,texte(langue,2)) codret
 535 c
 536       endif
 537 c
 538 #ifdef _DEBUG_HOMARD_
 539       write (ulsort,texte(langue,1)) 'Sortie', nompro
 540       call dmflsh (iaux)
 541 #endif
 542 c
 543       end