src/tool/AV_Conversion/vcmext.F

   1       subroutine vcmext ( lgopti, taopti, lgopts, taopts,
   2      >                    lgetco, taetco,
   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    aVant adaptation - Conversion de Maillage EXTrude
  25 c     -                 -             -        ---
  26 c    Pour un maillage initial
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . lgopti . e   .   1    . longueur du tableau des options            .
  32 c . taopti . e   . lgopti . tableau des options                        .
  33 c . lgopts . e   .   1    . longueur du tableau des options caracteres .
  34 c . taopts . e   . lgopts . tableau des options caracteres             .
  35 c . lgetco . e   .   1    . longueur du tableau de l'etat courant      .
  36 c . taetco . e   . lgetco . tableau de l'etat courant                  .
  37 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  38 c . langue . e   .    1   . langue des messages                        .
  39 c .        .     .        . 1 : francais, 2 : anglais                  .
  40 c . codret . es  .    1   . code de retour des modules                 .
  41 c .        .     .        . 0 : pas de probleme                        .
  42 c .        .     .        . 5 : mauvais type de code de calcul associe .
  43 c ______________________________________________________________________
  44 c
  45 c====
  46 c 0. declarations et dimensionnement
  47 c====
  48 c
  49 c 0.1. ==> generalites
  50 c
  51       implicit none
  52       save
  53 c
  54       character*6 nompro
  55       parameter ( nompro = 'VCMEXT' )
  56 c
  57 #include "nblang.h"
  58 #include "consts.h"
  59 c
  60 c 0.2. ==> communs
  61 c
  62 #include "gmenti.h"
  63 #include "gmreel.h"
  64 c
  65 #include "envex1.h"
  66 #include "nombno.h"
  67 #include "nombar.h"
  68 #include "nombtr.h"
  69 #include "nombqu.h"
  70 #include "nbfami.h"
  71 #include "dicfen.h"
  72 c
  73 c 0.3. ==> arguments
  74 c
  75       integer lgopti
  76       integer taopti(lgopti)
  77 c
  78       integer lgopts
  79       character*8 taopts(lgopts)
  80 c
  81       integer lgetco
  82       integer taetco(lgetco)
  83 c
  84       integer ulsort, langue, codret
  85 c
  86 c 0.4. ==> variables locales
  87 c
  88       integer nretap, nrsset
  89       integer iaux, jaux, kaux
  90       integer codre1, codre2, codre3, codre4
  91       integer codre0
  92       integer ptrav1, ptrav2, ptrav3, ptrav4
  93       integer ptrav5, ptrav6, ptrav7, ptrav8
  94       integer pcoono, pareno, phetno, adcocs
  95       integer psomar, phetar, pfilar, pmerar, pnp2ar
  96       integer paretr, phettr, pfiltr, ppertr, pnivtr, adnmtr, adpetr
  97       integer parequ, phetqu, pfilqu, pperqu, pnivqu, adnmqu, adhequ
  98       integer phethe, pquahe, pcoquh
  99       integer phetpe, pfacpe, pcofap
 100       integer pposif, pfacar
 101 c
 102       integer adnohn, adnocn
 103       integer adtrhn, adtrcn
 104       integer adquhn, adqucn
 105 c
 106       integer pfamno, pcfano, pcofno
 107       integer pfammp, pcfamp
 108       integer pfamar, pcfaar, pcofar
 109       integer pfamtr, pcfatr, pcoftr
 110       integer pfamqu, pcfaqu, pcofqu
 111       integer pfamhe, pcfahe
 112       integer pfampe, pcfape
 113       integer nbqure
 114       integer nbtrre
 115       integer nbarre
 116       integer nbnore
 117       integer nbp2re, nbimre
 118       integer nbfent
 119       integer adhono, adhoar, adhotr, adhoqu
 120       integer notfno, notfar, notftr, notfqu
 121       integer nofano, nofaar, nofatr, nofaqu
 122 c
 123       character*6 saux
 124       character*9 saux09
 125       character*8 nomail
 126       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 127       character*8 nhhexa, nhpent
 128       character*8 norenu
 129       character*8 nhnofa, nharfa, nhtrfa, nhqufa
 130       character*8 nhpefa
 131       character*8 nhenti, nhenfa
 132       character*8 ntrav1, ntrav2, ntrav3, ntrav4
 133       character*8 ntrav5, ntrav6, ntrav7, ntrav8
 134       character*8 nforfa(-1:4)
 135 c
 136       integer nbmess
 137       parameter ( nbmess = 10 )
 138       character*80 texte(nblang,nbmess)
 139 c
 140 c 0.5. ==> initialisations
 141 c ______________________________________________________________________
 142 c
 143 c====
 144 c 1. messages
 145 c====
 146 c
 147 #include "impr01.h"
 148 c
 149 #ifdef _DEBUG_HOMARD_
 150       write (ulsort,texte(langue,1)) 'Entree', nompro
 151       call dmflsh (iaux)
 152 #endif
 153 c
 154       if ( taopti(11).eq.26 ) then
 155         saux09 = 'SATURNE  '
 156       elseif ( taopti(11).eq.46 ) then
 157         saux09 = 'NEPTUNE  '
 158       else
 159         if ( langue.eq.1 ) then
 160           saux09 = 'EXTRUSION'
 161         else
 162           saux09 = 'EXTRUSION'
 163         endif
 164       endif
 165 c
 166       texte(1,4) =
 167      > '(/,a6,1x,'''//saux09//' - PASSAGE DU MAILLAGE 3D EN 2D'')'
 168       texte(1,5) = '(47(''=''),/)'
 169 c
 170       texte(2,4) = '(/,a6,1x,'''//saux09//' - FROM 3D MESH TO 2D'')'
 171       texte(2,5) = '(37(''=''),/)'
 172 c
 173 c 1.4. ==> le numero de sous-etape
 174 c
 175       nretap = taetco(1)
 176       nrsset = taetco(2) + 1
 177       taetco(2) = nrsset
 178 c
 179       call utcvne ( nretap, nrsset, saux, iaux, codret )
 180 c
 181 c 1.5 ==> le titre
 182 c
 183       write (ulsort,texte(langue,4)) saux
 184       write (ulsort,texte(langue,5))
 185 c
 186       codret = 0
 187 c
 188 #include "impr03.h"
 189 c
 190 c====
 191 c 2. les structures de base
 192 c====
 193 #ifdef _DEBUG_HOMARD_
 194       write (ulsort,90002) '2. structures de base ; codret', codret
 195 #endif
 196 c
 197 c 2.1. ==> Le maillage 3D au format HOMARD
 198 c
 199       nomail = taopts(3)
 200 c
 201 c 2.2. ==> Les adresses
 202 c
 203 #ifdef _DEBUG_HOMARD_
 204       write (ulsort,90002) '2.2. adresses ; codret', codret
 205 #endif
 206 c
 207       if ( codret.eq.0 ) then
 208 c
 209       iaux = 0
 210 #ifdef _DEBUG_HOMARD_
 211       write (ulsort,texte(langue,3)) 'VCMEXB', nompro
 212 #endif
 213       call vcmexb ( nomail,   iaux,
 214      >              phetno,
 215      >              pcoono, pareno, adhono, adcocs,
 216      >              adnohn, adnocn,
 217      >              phetar, psomar, pfilar, pmerar,
 218      >              pnp2ar, adhoar,
 219      >              phettr, paretr, pfiltr, ppertr,
 220      >              pnivtr, adnmtr, adhotr, adpetr,
 221      >              adtrhn, adtrcn,
 222      >              phetqu, parequ, pfilqu, pperqu,
 223      >              pnivqu, adnmqu, adhoqu, adhequ,
 224      >              adquhn, adqucn,
 225      >              phethe, pquahe, pcoquh,
 226      >              phetpe, pfacpe, pcofap,
 227      >              pfamno, pcfano,
 228      >              pfammp, pcfamp,
 229      >              pfamar, pcfaar,
 230      >              pfamtr, pcfatr,
 231      >              pfamqu, pcfaqu,
 232      >              pfamhe, pcfahe,
 233      >              pfampe, pcfape,
 234      >              pposif, pfacar,
 235      >              nhnoeu, nhmapo, nharet, nhtria, nhquad,
 236      >              nhhexa, nhpent, norenu,
 237      >              ulsort, langue, codret)
 238 c
 239       endif
 240 c
 241 c 2.3. ==> Sauvegarde des familles d'origine
 242 #ifdef _DEBUG_HOMARD_
 243       write (ulsort,90002) '2.3. Sauvegarde familles ; codret', codret
 244 #endif
 245 c
 246       if ( codret.eq.0 ) then
 247 c
 248       do 23 , iaux = -1, 4
 249 c
 250         if ( codret.eq.0 ) then
 251 c
 252         if ( iaux.eq.-1 ) then
 253           nhenti = nhnoeu
 254           nbfent = nbfnoe
 255         elseif ( iaux.eq.1 ) then
 256           nhenti = nharet
 257           nbfent = nbfare
 258         elseif ( iaux.eq.2 ) then
 259           nhenti = nhtria
 260           nbfent = nbftri
 261         elseif ( iaux.eq.4 ) then
 262           nhenti = nhquad
 263           nbfent = nbfqua
 264         else
 265           nforfa(iaux) = blan08
 266           goto 23
 267         endif
 268 c
 269         call gmnomc ( nhenti//'.Famille', nhenfa, codre0 )
 270         codret = max ( abs(codre0), codret )
 271 c
 272         endif
 273 c
 274         if ( codret.eq.0 ) then
 275 c
 276         if ( iaux.eq.-1 ) then
 277           nhnofa = nhenfa
 278         elseif ( iaux.eq.1 ) then
 279           nharfa = nhenfa
 280         elseif ( iaux.eq.2 ) then
 281           nhtrfa = nhenfa
 282         elseif ( iaux.eq.4 ) then
 283           nhqufa = nhenfa
 284         endif
 285 c
 286         jaux = 0
 287         call gmcpal ( nhenfa//'.Codes',
 288      >                nforfa(iaux), jaux, kaux, codre0 )
 289 c
 290         codret = max ( abs(codre0), codret )
 291 c
 292         endif
 293 #ifdef _DEBUG_HOMARD_
 294       write (ulsort,90012) '.. codre0123 apres phase',
 295      >                     iaux, codre0, codre1, codre2, codre3
 296 cgn      call gmprsx ( nompro, nforfa(iaux) )
 297 #endif
 298 c
 299         if ( codret.eq.0 ) then
 300 c
 301         if ( iaux.eq.-1 ) then
 302           pcofno = kaux
 303         elseif ( iaux.eq.1 ) then
 304           pcofar = kaux
 305         elseif ( iaux.eq.2 ) then
 306           pcoftr = kaux
 307         elseif ( iaux.eq.4 ) then
 308           pcofqu = kaux
 309         endif
 310 c
 311         endif
 312 c
 313    23 continue
 314 c
 315       endif
 316 c
 317 c 2.4. ==> Tableaux de travail
 318 #ifdef _DEBUG_HOMARD_
 319       write (ulsort,90002) '2.4. Tableaux de travail ; codret', codret
 320 #endif
 321 c
 322       if ( codret.eq.0 ) then
 323 c
 324       iaux = 2*nbnoto
 325       call gmalot ( ntrav1, 'entier  ',   iaux, ptrav1, codre1 )
 326       iaux = 4*nbarto
 327       call gmalot ( ntrav2, 'entier  ',   iaux, ptrav2, codre2 )
 328       iaux = 3*nbtrto
 329       call gmalot ( ntrav3, 'entier  ',   iaux, ptrav3, codre3 )
 330       iaux = 3*nbquto
 331       call gmalot ( ntrav4, 'entier  ',   iaux, ptrav4, codre4 )
 332 c
 333       codre0 = min ( codre1, codre2, codre3, codre4 )
 334       codret = max ( abs(codre0), codret,
 335      >               codre1, codre2, codre3, codre4 )
 336 c
 337       call gmalot ( ntrav5, 'entier  ', nbnoto, ptrav5, codre1 )
 338       call gmalot ( ntrav6, 'entier  ', nbarto, ptrav6, codre2 )
 339       call gmalot ( ntrav7, 'entier  ', nbtrto, ptrav7, codre3 )
 340       call gmalot ( ntrav8, 'entier  ', nbquto, ptrav8, codre4 )
 341 c
 342       codre0 = min ( codre1, codre2, codre3, codre4 )
 343       codret = max ( abs(codre0), codret,
 344      >               codre1, codre2, codre3, codre4 )
 345 c
 346       endif
 347 c
 348 c====
 349 c 3. Reperage du positionnement des entites
 350 c====
 351 #ifdef _DEBUG_HOMARD_
 352       write (ulsort,90002) '3. reperage ; codret', codret
 353 #endif
 354 c
 355       if ( codret.eq.0 ) then
 356 c
 357       iaux = 1
 358 #ifdef _DEBUG_HOMARD_
 359       write (ulsort,texte(langue,3)) 'VCMEX0', nompro
 360 #endif
 361       call vcmex0 ( iaux,
 362      >              rmem(adcocs),
 363      >              rmem(pcoono), imem(ptrav5),
 364      >              imem(psomar), imem(ptrav6),
 365      >              imem(paretr), imem(ptrav7),
 366      >              imem(parequ), imem(ptrav8), imem(ptrav4),
 367      >              ulsort, langue, codret )
 368 c
 369 #ifdef _DEBUG_HOMARD_
 370       call gmprsx ('Position des noeuds :', ntrav5)
 371       call gmprsx ('Position des aretes :', ntrav6)
 372       call gmprsx ('Position des triangles :', ntrav7)
 373       call gmprsx ('Position des quadrangles :', ntrav8)
 374 #endif
 375 c
 376       endif
 377 c
 378 c====
 379 c 4. Memorisation des informations pour l'extrusion
 380 c====
 381 #ifdef _DEBUG_HOMARD_
 382       write (ulsort,90002) '4. Memorisation extrusion ; codret', codret
 383 #endif
 384 c
 385       if ( codret.eq.0 ) then
 386 c
 387 #ifdef _DEBUG_HOMARD_
 388       write (ulsort,texte(langue,3)) 'VCMEX1', nompro
 389 #endif
 390       call vcmex1 (               imem(pfamno),
 391      >              imem(ptrav5), imem(ptrav1),
 392      >              imem(psomar), imem(pfamar),
 393      >              imem(ptrav6), imem(ptrav2),
 394      >                            imem(pfamtr),
 395      >              imem(ptrav7), imem(ptrav3), imem(adpetr),
 396      >              imem(parequ), imem(pfamqu),
 397      >              imem(ptrav8), imem(ptrav4), imem(adhequ),
 398      >              imem(pquahe), imem(pcoquh), imem(pfamhe),
 399      >              imem(pfacpe), imem(pcofap), imem(pfampe),
 400      >              ulsort, langue, codret )
 401 c
 402 #ifdef _DEBUG_HOMARD_
 403       call gmprsx ('inxnoe - noeuds :', ntrav1)
 404       call gmprsx ('inxare - aretes :', ntrav2)
 405       call gmprsx ('inxtri - triangles :', ntrav3)
 406       call gmprsx ('inxqua - quadrangles :', ntrav4)
 407 #endif
 408 c
 409       endif
 410 c
 411 c====
 412 c 5. Creation des tableaux de memorisation des familles
 413 c====
 414 #ifdef _DEBUG_HOMARD_
 415       write (ulsort,90002) '5. creation tableaux ; codret', codret
 416 #endif
 417 c 5.1. ==> Les familles des pentaedres
 418 c
 419       if ( codret.eq.0 ) then
 420 c
 421       call gmnomc ( nhpent//'.Famille', nhpefa, codre0 )
 422       codret = max ( abs(codre0), codret )
 423 c
 424       endif
 425 c
 426 c 5.2. ==> La creation
 427 c
 428 #ifdef _DEBUG_HOMARD_
 429       write (ulsort,90002) '5.2. creation ; codret', codret
 430 #endif
 431       if ( codret.eq.0 ) then
 432 c
 433       notfno = nctfno
 434       notfar = nctfar
 435       notftr = nctftr
 436       notfqu = nctfqu
 437 c
 438       nofano = nbfnoe
 439       nofaar = nbfare
 440       nofatr = nbftri
 441       nofaqu = nbfqua
 442 c
 443 #ifdef _DEBUG_HOMARD_
 444       write (ulsort,texte(langue,3)) 'VCMEX2', nompro
 445 #endif
 446       call vcmex2 (
 447      >        taopti(30),
 448      >        nhnofa, imem(pfamno), notfno, nofano, imem(pcofno),
 449      >        imem(ptrav5), imem(ptrav1), pcfano,
 450      >        nharfa, imem(pfamar), notfar, nofaar, imem(pcofar),
 451      >        imem(ptrav6), imem(ptrav2), pcfaar,
 452      >        nhtrfa, imem(pfamtr), notftr, nofatr, imem(pcoftr),
 453      >        imem(ptrav7), imem(ptrav3), pcfatr,
 454      >        nhqufa, imem(pfamqu), notfqu, nofaqu, imem(pcofqu),
 455      >        imem(ptrav8), imem(ptrav4), pcfaqu,
 456      >        pcfahe,
 457      >        nhpefa, pcfape,
 458      >        ulsort, langue, codret )
 459 c
 460       endif
 461 c
 462 c====
 463 c 6. Destruction des entites inutiles
 464 c====
 465 #ifdef _DEBUG_HOMARD_
 466       write (ulsort,90002) '6. destruction ; codret', codret
 467 #endif
 468 c
 469       if ( codret.eq.0 ) then
 470 c
 471 #ifdef _DEBUG_HOMARD_
 472       write (ulsort,texte(langue,3)) 'VCMEXD', nompro
 473 #endif
 474       call vcmexd ( nomail,
 475      >           nhnoeu, nharet, nhtria, nhquad,
 476      >           nhhexa, nhpent, norenu,
 477      >           imem(ptrav5), nbnore, nbp2re, nbimre,
 478      >           imem(phetno), rmem(pcoono),
 479      >           imem(pareno), imem(adhono),
 480      >           imem(adnocn), imem(adnohn),
 481      >           imem(ptrav6), nbarre,
 482      >           imem(phetar), imem(psomar), imem(pmerar), imem(pfilar),
 483      >           imem(pnp2ar), imem(adhoar),
 484      >           imem(pposif), imem(pfacar),
 485      >           imem(ptrav7), nbtrre,
 486      >           imem(phettr), imem(paretr), imem(ppertr), imem(pfiltr),
 487      >           imem(pnivtr), imem(adpetr), imem(adnmtr), imem(adhotr),
 488      >           imem(adtrcn), imem(adtrhn),
 489      >           imem(ptrav8), nbqure,
 490      >           imem(phetqu), imem(parequ), imem(pperqu), imem(pfilqu),
 491      >           imem(pnivqu), imem(adhequ), imem(adnmqu),
 492      >           imem(adqucn), imem(adquhn),
 493      >           rmem(adcocs),
 494      >           imem(pfamno), imem(pcfano),
 495      >           imem(pfammp), imem(pcfamp),
 496      >           imem(pfamar), imem(pcfaar),
 497      >           imem(pfamtr), imem(pcfatr),
 498      >           imem(pfamqu), imem(pcfaqu),
 499      >           imem(pcfahe),
 500      >           imem(pcfape),
 501      >           ulsort, langue, codret)
 502 c
 503       endif
 504 c
 505 c====
 506 c 7. Menage
 507 c====
 508 #ifdef _DEBUG_HOMARD_
 509       write (ulsort,90002) '7. menage ; codret', codret
 510 #endif
 511 c
 512       if ( codret.eq.0 ) then
 513 c
 514       call gmlboj ( ntrav1 , codre1  )
 515       call gmlboj ( ntrav2 , codre2  )
 516       call gmlboj ( ntrav3 , codre3  )
 517       call gmlboj ( ntrav4 , codre4  )
 518 c
 519       codre0 = min ( codre1, codre2, codre3, codre4 )
 520       codret = max ( abs(codre0), codret,
 521      >               codre1, codre2, codre3, codre4 )
 522 c
 523       call gmlboj ( ntrav5 , codre1  )
 524       call gmlboj ( ntrav6 , codre2  )
 525       call gmlboj ( ntrav7 , codre3  )
 526       call gmlboj ( ntrav8 , codre4  )
 527 c
 528       codre0 = min ( codre1, codre2, codre3, codre4 )
 529       codret = max ( abs(codre0), codret,
 530      >               codre1, codre2, codre3, codre4 )
 531 c
 532       do 71 , iaux = -1, 4
 533 c
 534         if ( nforfa(iaux).ne.blan08 ) then
 535           call gmlboj ( nforfa(iaux) , codre0 )
 536           codret = max ( abs(codre0), codret )
 537         endif
 538 c
 539    71   continue
 540 c
 541       endif
 542 c
 543 cgn      call gmprsx ( nompro, nhtria//'.InfoSupp' )
 544 cgn      call gmprsx ( nompro, norenu//'.TrCalcul' )
 545 cgn      call gmprsx ( nompro, norenu//'.TrHOMARD' )
 546 cgn      call gmprsx ( nompro, norenu//'.PeCalcul' )
 547 cgn      call gmprsx ( nompro, norenu//'.PeHOMARD' )
 548 cgn      call gmprsx ( nompro, nhquad//'.InfoSupp' )
 549 cgn      call gmprsx ( nompro, norenu//'.QuCalcul' )
 550 cgn      call gmprsx ( nompro, norenu//'.QuHOMARD' )
 551 cgn      call gmprsx ( nompro, norenu//'.HeCalcul' )
 552 cgn      call gmprsx ( nompro, norenu//'.HeHOMARD' )
 553 c
 554 c====
 555 c 8. la fin
 556 c====
 557 c
 558       if ( codret.ne.0 ) then
 559 c
 560 #include "envex2.h"
 561 c
 562       write (ulsort,texte(langue,1)) 'Sortie', nompro
 563       write (ulsort,texte(langue,2)) codret
 564 c
 565       endif
 566 c
 567 #ifdef _DEBUG_HOMARD_
 568       write (ulsort,texte(langue,1)) 'Sortie', nompro
 569       call dmflsh (iaux)
 570 #endif
 571 c
 572       end