src/tool/AV_Conversion/vcmex1.F

   1       subroutine vcmex1 (         famnoe, posnoe, inxnoe,
   2      >                    somare, famare, posare, inxare,
   3      >                            famtri,
   4      >                    postri, inxtri, pentri,
   5      >                    arequa, famqua, posqua, inxqua, hexqua,
   6      >                    quahex, coquhe, famhex,
   7      >                    facpen, cofape, fampen,
   8      >                    ulsort, langue, codret )
   9 c ______________________________________________________________________
  10 c
  11 c                             H O M A R D
  12 c
  13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  14 c
  15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  16 c aupres des huissiers de justice Simart et Lavoir a Clamart
  17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  18 c aupres des huissiers de justice
  19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  20 c
  21 c    HOMARD est une marque deposee d'Electricite de France
  22 c
  23 c Copyright EDF 1996
  24 c Copyright EDF 1998
  25 c Copyright EDF 2002
  26 c Copyright EDF 2020
  27 c ______________________________________________________________________
  28 c
  29 c    aVant adaptation - Conversion de Maillage EXtrude - phase 1
  30 c     -                 -             -        --              -
  31 c Memorise les informations pour l'extrusion
  32 c ______________________________________________________________________
  33 c .        .     .        .                                            .
  34 c .  nom   . e/s . taille .           description                      .
  35 c .____________________________________________________________________.
  36 c . famnoe . e   . nbnoto . famille des noeuds                         .
  37 c . posnoe . e   . nbnoto . position des noeuds                        .
  38 c .        .     .        . 0 : face avant                             .
  39 c .        .     .        . 1 : face arriere                           .
  40 c . inxnoe .  s  .2*nbnoto. informations pour l'extrusion des noeuds   .
  41 c .        .     .        . 1 : famille du noeud extrude               .
  42 c .        .     .        . 2 : famille de l'arete perpendiculaire     .
  43 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  44 c . famare . e   . nbarto . famille des aretes                         .
  45 c . posare . e   . nbarto . position des aretes                        .
  46 c .        .     .        . 0 : arete avant                            .
  47 c .        .     .        . 1 : arete arriere                          .
  48 c .        .     .        . 2 : arete perpendiculaire                  .
  49 c . inxare .  s  .4*nbarto. informations pour l'extrusion des aretes   .
  50 c .        .     .        . 1 : famille de l'arete extrudee            .
  51 c .        .     .        . 2 : famille du quadrangle perpendiculaire  .
  52 c .        .     .        . 3 : code du quadrangle dans le volume      .
  53 c .        .     .        . 4 : quadrangle perpendiculaire             .
  54 c . famtri . e   . nbtrto . famille des triangles                      .
  55 c . postri . e   . nbtrto . position des triangles                     .
  56 c .        .     .        . 0 : face avant                             .
  57 c .        .     .        . 1 : face arriere                           .
  58 c .        .     .        . 2 : face perpendiculaire                   .
  59 c . inxtri .  s  .3*nbtrto. informations pour l'extrusion des triangles.
  60 c .        .     .        . 1 : famille du triangle extrude            .
  61 c .        .     .        . 2 : famille du pentaedre                   .
  62 c .        .     .        . 3 : code du triangle dans le pentaedre     .
  63 c . pentri .  s  . nbtrto . pentaedre sur un triangle de la face avant .
  64 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  65 c . famqua . e   . nbquto . famille des quadrangles                    .
  66 c . posqua . e   . nbquto . position des quadrangles                   .
  67 c .        .     .        . 0 : face avant                             .
  68 c .        .     .        . 1 : face arriere                           .
  69 c .        .     .        . 2 : face perpendiculaire                   .
  70 c . inxqua . es  .3*nbquto. informations pour l'extrusion des quads    .
  71 c .        .     .        . Pour un quadrangle a l'avant :             .
  72 c .        .     .        .  1 : famille du quadrangle extrude         .
  73 c .        .     .        .  2 : famille de l'hexaedre                 .
  74 c .        .     .        .  3 : orientation du quadrangle dans le vol..
  75 c .        .     .        . Pour un quadrangle a l'arriere :           .
  76 c .        .     .        .  1 : inutile                               .
  77 c .        .     .        .  2 : inutile                               .
  78 c .        .     .        .  3 : orientation du quadrangle dans le vol..
  79 c .        .     .        . Pour un quadrangle perpendiculaire :       .
  80 c .        .     .        .  1 : sens de la 1ere compos. de la normale .
  81 c .        .     .        .  2 : sens de la 2eme compos. de la normale .
  82 c .        .     .        .  3 : orientation du quadrangle dans le vol..
  83 c . hexqua .  s  . nbquto . hexaedre sur un quadrangle de la face avant.
  84 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  85 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  86 c . famhex . e   . nbheto . famille des hexaedres                      .
  87 c . facpen . e   .nbpecf*5. numeros des faces des pentaedres           .
  88 c . cofape . e   .nbpecf*5. code des 5 faces des pentaedres            .
  89 c . fampen . e   . nbpeto . famille des pentaedres                     .
  90 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  91 c . langue . e   .    1   . langue des messages                        .
  92 c .        .     .        . 1 : francais, 2 : anglais                  .
  93 c . codret . es  .    1   . code de retour des modules                 .
  94 c .        .     .        . 0 : pas de probleme                        .
  95 c .        .     .        . 1 : probleme                               .
  96 c ______________________________________________________________________
  97 c
  98 c====
  99 c 0. declarations et dimensionnement
 100 c====
 101 c
 102 c 0.1. ==> generalites
 103 c
 104       implicit none
 105       save
 106 c
 107       character*6 nompro
 108       parameter ( nompro = 'VCMEX1' )
 109 c
 110 #include "nblang.h"
 111 c
 112 c 0.2. ==> communs
 113 c
 114 #include "envex1.h"
 115 c
 116 #include "nombno.h"
 117 #include "nombar.h"
 118 #include "nombtr.h"
 119 #include "nombqu.h"
 120 #include "nombhe.h"
 121 #include "nombpe.h"
 122 c
 123 #include "ope1a4.h"
 124 c
 125 c 0.3. ==> arguments
 126 c
 127       integer                   famnoe(nbnoto)
 128       integer posnoe(nbnoto), inxnoe(2,nbnoto)
 129       integer somare(2,nbarto), famare(nbarto)
 130       integer posare(nbarto), inxare(4,nbarto)
 131       integer                   famtri(nbtrto)
 132       integer postri(nbtrto), inxtri(3,nbtrto), pentri(nbtrto)
 133       integer arequa(nbquto,4), famqua(nbquto)
 134       integer posqua(nbquto), inxqua(3,nbquto), hexqua(nbquto)
 135       integer quahex(nbhecf,6), coquhe(nbhecf,6), famhex(nbheto)
 136       integer facpen(nbpecf,5), cofape(nbpecf,5), fampen(nbpeto)
 137 c
 138       integer ulsort, langue, codret
 139 c
 140 c 0.4. ==> variables locales
 141 c
 142       integer iaux, jaux, kaux
 143       integer iaux1, iaux2, iaux3, iaux4
 144       integer lehexa, lepent
 145       integer facear, cofaar
 146       integer faceav, cofaav
 147       integer facepp
 148       integer aretar, aretav, aretpp
 149       integer noeuar, noeuav
 150 c
 151       integer nbmess
 152       parameter ( nbmess = 10 )
 153       character*80 texte(nblang,nbmess)
 154 c
 155 c 0.5. ==> initialisations
 156 c ______________________________________________________________________
 157 c
 158 c====
 159 c 1. messages
 160 c====
 161 c
 162 #include "impr01.h"
 163 c
 164 #ifdef _DEBUG_HOMARD_
 165       write (ulsort,texte(langue,1)) 'Entree', nompro
 166       call dmflsh (iaux)
 167 #endif
 168 c
 169 #include "impr03.h"
 170 c
 171       codret = 0
 172 c
 173 c====
 174 c 2. Prealables : rien n'est vu
 175 c====
 176 #ifdef _DEBUG_HOMARD_
 177       write (ulsort,90002) '2. Prealables ; codret', codret
 178 #endif
 179 c
 180       do 21 , iaux = 1 , nbarto
 181         inxare(1,iaux) = -1
 182    21 continue
 183 c
 184       do 22 , iaux = 1 , nbtrto
 185         pentri(iaux) = 0
 186    22 continue
 187 c
 188       do 23 , iaux = 1 , nbquto
 189         inxqua(3,iaux) = -1
 190         hexqua(iaux) = 0
 191    23 continue
 192 c
 193 c====
 194 c 3. Examen des hexaedres
 195 c====
 196 #ifdef _DEBUG_HOMARD_
 197       write (ulsort,90002) '3. hexaedres ; codret', codret
 198 #endif
 199 c
 200       if ( codret.eq.0 ) then
 201 c
 202 #ifdef _DEBUG_HOMARD_
 203       write (ulsort,90002) 'nbheto', nbheto
 204 #endif
 205 c
 206       do 31 , lehexa = 1 , nbheto
 207 c
 208 c 3.1. ==> Bases quadrangulaires
 209 c
 210 cgn        write (ulsort,90012) 'faces de l''hexa', lehexa,
 211 cgn     >        ( quahex(lehexa,jaux) , jaux = 1 , 6)
 212 cgn        write (ulsort,90012) 'faces de l''hexa', lehexa,
 213 cgn     >        ( inxqua(1,quahex(lehexa,jaux)) , jaux = 1 , 6)
 214         do 311 , jaux = 1 , 6
 215           iaux1 = quahex(lehexa,jaux)
 216           if ( posqua(iaux1).eq.0 ) then
 217             faceav = iaux1
 218             cofaav = coquhe(lehexa,jaux)
 219           elseif ( posqua(iaux1).eq.1 ) then
 220             facear = iaux1
 221             cofaar = coquhe(lehexa,jaux)
 222           endif
 223   311   continue
 224 cgn        write (ulsort,90002) '.. faces de base', faceav, facear
 225 c
 226 cgn        write (ulsort,90002) '.. quad/hexa', faceav, lehexa
 227         inxqua(1,faceav) = famqua(facear)
 228         inxqua(2,faceav) = famhex(lehexa)
 229         inxqua(3,faceav) = cofaav
 230         inxqua(1,facear) = 0
 231         inxqua(2,facear) = 0
 232         inxqua(3,facear) = cofaar
 233         hexqua(faceav) = lehexa
 234 c
 235 c 3.2. ==> Faces perpendiculaires a l'extrusion
 236 c          Remarque : une face n'est traitee qu'une fois, inxqua(3,.)<0
 237 c
 238         do 312 , jaux = 1 , 6
 239 c
 240           facepp = quahex(lehexa,jaux)
 241           if ( inxqua(3,facepp).lt.0 ) then
 242 c
 243 cgn      write (ulsort,90002) 'quad perp', facepp
 244 c
 245 c 3.2.1. ==> reperage des aretes avant et arriere
 246 c
 247             do 3211 , kaux = 1, 4
 248               if ( posare(arequa(facepp,kaux)).eq.0 ) then
 249                 iaux1 = kaux
 250               endif
 251  3211       continue
 252             aretav = arequa(facepp,iaux1)
 253             aretar = arequa(facepp,per1a4(2,iaux1))
 254 cgn      write (ulsort,90002) 'aretes av/ar', aretav, aretar
 255 c
 256 c 3.2.2. ==> informations pour les aretes avant et arriere
 257 c
 258             inxare(1,aretav) = famare(aretar)
 259             inxare(2,aretav) = famqua(facepp)
 260             inxare(3,aretav) = coquhe(lehexa,jaux)
 261             inxare(4,aretav) = facepp
 262 c
 263 c 3.2.3. ==> les deux aretes perpendiculaires
 264 c
 265             do 3213 , kaux = 1 , 2
 266 c
 267 c 3.2.3.1. ==> numero de l'arete perpendiculaire
 268 c
 269               if ( kaux.eq.1 ) then
 270                 iaux2 = per1a4(1,iaux1)
 271               else
 272                 iaux2 = per1a4(3,iaux1)
 273               endif
 274               aretpp = arequa(facepp,iaux2)
 275 c
 276               if ( inxare(1,aretpp).lt.0 ) then
 277 cgn        write (ulsort,90002) '.... arete perp 1', aretpp
 278 c
 279 c 3.2.3.2. ==> les deux sommets avant et arriere
 280 c
 281                 iaux3 = somare(1,aretpp)
 282                 iaux4 = somare(2,aretpp)
 283                 if ( posnoe(iaux3).eq.0 ) then
 284                   noeuav = iaux3
 285                   noeuar = iaux4
 286                 else
 287                   noeuav = iaux4
 288                   noeuar = iaux3
 289                 endif
 290 cgn          write (ulsort,90002) '.... noeuds av/ar', noeuav, noeuar
 291                 inxnoe(1,noeuav) = famnoe(noeuar)
 292                 inxnoe(2,noeuav) = famare(aretpp)
 293                 inxare(1,aretpp) = 0
 294               endif
 295 c
 296  3213       continue
 297 c
 298 c 4.2.4. ==> Code de la face
 299 c
 300             inxqua(3,facepp) = coquhe(lehexa,jaux)
 301 c
 302           endif
 303 c
 304   312   continue
 305
 306 c
 307    31 continue
 308 c
 309       endif
 310 c
 311 c====
 312 c 4. Examen des pentaedres
 313 c====
 314 #ifdef _DEBUG_HOMARD_
 315       write (ulsort,90002) '4. pentaedres ; codret', codret
 316 #endif
 317 c
 318       if ( codret.eq.0 ) then
 319 c
 320 #ifdef _DEBUG_HOMARD_
 321       write (ulsort,90002) 'nbpeto', nbpeto
 322 #endif
 323 c
 324       do 41 , lepent = 1 , nbpeto
 325 c
 326 c 4.1. ==> Bases triangulaires
 327 c
 328 cgn        write (ulsort,90012) 'faces du pentaedre', lepent,
 329 cgn     >        ( facpen(lepent,jaux) , jaux = 1 , 5)
 330 cgn        write (ulsort,90012) 'faces du pentaedre', lepent,
 331 cgn     >        ( inxtri(1,facpen(lepent,jaux)) , jaux = 1 , 2),
 332 cgn     >        ( inxqua(1,facpen(lepent,jaux)) , jaux = 3 , 5)
 333         iaux1 = facpen(lepent,1)
 334         iaux2 = facpen(lepent,2)
 335         if ( postri(iaux1) .eq.0 ) then
 336           faceav = iaux1
 337           cofaav = cofape(lepent,1)
 338           facear = iaux2
 339           cofaar = cofape(lepent,2)
 340         else
 341           faceav = iaux2
 342           cofaav = cofape(lepent,2)
 343           facear = iaux1
 344           cofaar = cofape(lepent,1)
 345         endif
 346 cgn        write (ulsort,90002) '.. faces de base', faceav, facear
 347 c
 348 cgn        write (ulsort,90002) '.. tria/pent', faceav, lepent
 349         inxtri(1,faceav) = famtri(facear)
 350         inxtri(2,faceav) = fampen(lepent)
 351         inxtri(3,faceav) = cofaav
 352         inxtri(1,facear) = 0
 353         inxtri(2,facear) = 0
 354         inxtri(3,facear) = cofaar
 355         pentri(faceav) = lepent
 356 c
 357 c 4.2. ==> Faces perpendiculaires a l'extrusion
 358 c          Remarque : on ne traite qu'une seule fois, inxqua(3,.)<0
 359 c
 360         do 421 , jaux = 3 , 5
 361 c
 362           facepp = facpen(lepent,jaux)
 363           if ( inxqua(3,facepp).lt.0 ) then
 364 c
 365 cgn      write (ulsort,90002) '.. quad perp', facepp
 366 c
 367 c 4.2.1. ==> reperage des aretes avant et arriere
 368 c
 369             do 4211 , kaux = 1, 4
 370               if ( posare(arequa(facepp,kaux)).eq.0 ) then
 371                 iaux1 = kaux
 372               endif
 373  4211       continue
 374             aretav = arequa(facepp,iaux1)
 375             aretar = arequa(facepp,per1a4(2,iaux1))
 376 cgn      write (ulsort,90002) '.... aretes av/ar', aretav, aretar
 377 c
 378 c 4.2.2. ==> informations pour les aretes avant et arriere
 379 c
 380             inxare(1,aretav) = famare(aretar)
 381             inxare(2,aretav) = famqua(facepp)
 382             inxare(3,aretav) = cofape(lepent,jaux)
 383             inxare(4,aretav) = facepp
 384 c
 385 c 4.2.3. ==> les deux aretes perpendiculaires
 386 c
 387             do 4213 , kaux = 1 , 2
 388 c
 389 c 4.2.3.1. ==> numero de l'arete perpendiculaire
 390 c
 391               if ( kaux.eq.1 ) then
 392                 iaux2 = per1a4(1,iaux1)
 393               else
 394                 iaux2 = per1a4(3,iaux1)
 395               endif
 396               aretpp = arequa(facepp,iaux2)
 397 c
 398               if ( inxare(1,aretpp).lt.0 ) then
 399 cgn        write (ulsort,90002) '.... arete perp 1', aretpp
 400 c
 401 c 4.2.3.2. ==> les deux sommets avant et arriere
 402 c
 403                 iaux3 = somare(1,aretpp)
 404                 iaux4 = somare(2,aretpp)
 405                 if ( posnoe(iaux3).eq.0 ) then
 406                   noeuav = iaux3
 407                   noeuar = iaux4
 408                 else
 409                   noeuav = iaux4
 410                   noeuar = iaux3
 411                 endif
 412 cgn          write (ulsort,90002) '.... noeuds av/ar', noeuav, noeuar
 413                 inxnoe(1,noeuav) = famnoe(noeuar)
 414                 inxnoe(2,noeuav) = famare(aretpp)
 415                 inxare(1,aretpp) = 0
 416               endif
 417 c
 418  4213       continue
 419 c
 420 c 4.2.4. ==> Code de la face
 421 c
 422             inxqua(3,facepp) = cofape(lepent,jaux)
 423 c
 424           endif
 425 c
 426   421   continue
 427 c
 428    41 continue
 429 c
 430       endif
 431 c
 432 #ifdef _DEBUG_HOMARD_
 433 49900 format(/,24x,a)
 434       write(ulsort,49900) ' famille fa noe ex  fa arete'
 435       do 4991 , iaux = 1 , nbnoto
 436         if ( posnoe(iaux).eq.0 ) then
 437         write(ulsort,90012) 'noeud',iaux,famnoe(iaux),
 438      >                      inxnoe(1,iaux),inxnoe(2,iaux)
 439         endif
 440  4991 continue
 441 c
 442       write(ulsort,49900)
 443      > ' famille fa are ex   fa quad code q/vo face perp'
 444       do 4992 , iaux = 1 , nbarto
 445         if ( posare(iaux).eq.0 ) then
 446         write(ulsort,90012) 'arete',iaux,famare(iaux),
 447      >               inxare(1,iaux),inxare(2,iaux),inxare(3,iaux)
 448         endif
 449  4992 continue
 450 c
 451       write(ulsort,49900) 'famille fa tri ex   fa pent code t/pe'
 452       do 4993 , iaux = 1 , nbtrto
 453         if ( postri(iaux).eq.0 ) then
 454         write(ulsort,90012) 'tria',iaux,famtri(iaux),
 455      >               inxtri(1,iaux),inxtri(2,iaux),inxtri(3,iaux)
 456         endif
 457  4993 continue
 458 c
 459       write(ulsort,49900)
 460      >'famille  position fa qua ex   fa hexa code q/vo'
 461       do 4994 , iaux = 1 , nbquto
 462         write(ulsort,90012) 'quad',iaux,famqua(iaux),posqua(iaux),
 463      >               inxqua(1,iaux),inxqua(2,iaux),inxqua(3,iaux)
 464  4994 continue
 465 #endif
 466 c
 467 c====
 468 c 5. la fin
 469 c====
 470 c
 471       if ( codret.ne.0 ) then
 472 c
 473 #include "envex2.h"
 474 c
 475       write (ulsort,texte(langue,1)) 'Sortie', nompro
 476       write (ulsort,texte(langue,2)) codret
 477 c
 478       endif
 479 c
 480 #ifdef _DEBUG_HOMARD_
 481       write (ulsort,texte(langue,1)) 'Sortie', nompro
 482       call dmflsh (iaux)
 483 #endif
 484 c
 485       end