src/tool/AV_Conversion/vcme22.F

   1       subroutine vcme22 ( typenh, nument, cofxeo,
   2      >                    nbinfx, nctfen, nbenti,
   3      >                    notfen, nofaen, cofaen,
   4      >                    nbfae0, nbfaen, cfaent,
   5      >                    fament, posent, inxent,
   6      >                    ulsort, langue, codret )
   7 c ______________________________________________________________________
   8 c
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c
  27 c    aVant adaptation - Conversion de Maillage Extrude - phase 22
  28 c     -                 -             -        -              --
  29 c Determine les familles pour un type de mailles de la face avant
  30 c ______________________________________________________________________
  31 c .        .     .        .                                            .
  32 c .  nom   . e/s . taille .           description                      .
  33 c .____________________________________________________________________.
  34 c . typenh . e   .    1   . type d'entites                             .
  35 c .        .     .        .  -1 : noeuds                               .
  36 c .        .     .        .   0 : mailles-points                       .
  37 c .        .     .        .   1 : segments                             .
  38 c .        .     .        .   2 : triangles                            .
  39 c .        .     .        .   3 : tetraedres                           .
  40 c .        .     .        .   4 : quadrangles                          .
  41 c .        .     .        .   5 : pyramides                            .
  42 c .        .     .        .   6 : hexaedres                            .
  43 c .        .     .        .   7 : pentaedres                           .
  44 c . nument . es  .    1   . numero de la derniere entite traitee       .
  45 c . cofxeo . e   .    1   . orientation de l'entite comme face/volume  .
  46 c . nbinfx . e   .    1   . nombre d'informations pour inxent          .
  47 c . nctfen . e   .    1   . nombre de caracteristique des f. entite    .
  48 c . nbenti . e   .    1   . nombre d'entites                           .
  49 c . notfen . e   .  1     . nombre d'origine des carac. des f. entite  .
  50 c . nofaen . e   .  1     . nombre d'origine de familles de l'entite   .
  51 c . cofaen . e   . notfen*. codes d'origine des familles de l'entite   .
  52 c .        .     . nofaen .                                            .
  53 c . fament . e   . nbenti . famille des entites                        .
  54 c . posent . e   . nbenti . position des entites                       .
  55 c .        .     .        . 0 : face avant                             .
  56 c .        .     .        . 1 : face arriere                           .
  57 c .        .     .        . 2 : perpendiculaire                        .
  58 c . inxent . e   . nbinfx*. informations pour l'extrusion des entites  .
  59 c .        .     . nbenti . 1 : famille de l'entite extrudee           .
  60 c .        .     .        . 2 : famille de l'entite perpendiculaire    .
  61 c .        .     .        . Si triangle ou quadrangle :                .
  62 c .        .     .        . 3 : code de la face dans le volume         .
  63 c . nbfae0 .  e  .  1     . nombre de familles pour le dimensionnement .
  64 c . nbfaen .  es .  1     . nombre de familles enregistrees            .
  65 c . cfaent .  es . nctfen*. codes des familles d'entites               .
  66 c .        .     . nbfaen .   1 : famille MED                          .
  67 c .        .     .        . si maille-point :                          .
  68 c .        .     .        .   2 : type de maille-point                 .
  69 c .        .     .        .   3 : famille des sommets                  .
  70 c .        .     .        . si arete :                                 .
  71 c .        .     .        .   2 : type de segment                      .
  72 c .        .     .        .   3 : orientation                          .
  73 c .        .     .        .   4 : famille d'orientation inverse        .
  74 c .        .     .        .   5 : numero de ligne de frontiere         .
  75 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
  76 c .        .     .        . <= 0 si non concernee                      .
  77 c .        .     .        .   6 : famille frontiere active/inactive    .
  78 c .        .     .        .   7 : numero de surface de frontiere       .
  79 c .        .     .        . + l : appartenance a l'equivalence l       .
  80 c .        .     .        . si triangle :                              .
  81 c .        .     .        .   2 : type de triangle                     .
  82 c .        .     .        .   3 : numero de surface de frontiere       .
  83 c .        .     .        .   4 : famille des aretes internes apres raf.
  84 c .        .     .        . + l : appartenance a l'equivalence l       .
  85 c .        .     .        . si quadrangle :                            .
  86 c .        .     .        .   2 : type de quadrangle                   .
  87 c .        .     .        .   3 : numero de surface de frontiere       .
  88 c .        .     .        .   4 : famille des aretes internes apres raf.
  89 c .        .     .        .   5 : famille des triangles de conformite  .
  90 c .        .     .        .   6 : famille de sf active/inactive        .
  91 c .        .     .        . + l : appartenance a l'equivalence l       .
  92 c .        .     .        . si extrusion et noeud/arete/tria/quad :    .
  93 c .        .     .        . n+1 : famille de l'entite extrudee         .
  94 c .        .     .        . n+2 : famille de l'entite perpendiculaire  .
  95 c .        .     .        . si extrusion et triangle ou quadrangle :   .
  96 c .        .     .        . n+3 : code de la face dans le volume       .
  97 c .        .     .        . si extrusion :                             .
  98 c .        .     .        . n+3/4 : position de l'entite               .
  99 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 100 c . langue . e   .    1   . langue des messages                        .
 101 c .        .     .        . 1 : francais, 2 : anglais                  .
 102 c . codret . e   .    1   . code de retour des modules                 .
 103 c .        .     .        . 0 : pas de probleme                        .
 104 c .        .     .        . 1 : probleme                               .
 105 c ______________________________________________________________________
 106 c
 107 c====
 108 c 0. declarations et dimensionnement
 109 c====
 110 c
 111 c 0.1. ==> generalites
 112 c
 113       implicit none
 114       save
 115 c
 116       character*6 nompro
 117       parameter ( nompro = 'VCME22' )
 118 c
 119 #include "nblang.h"
 120 #include "cofaar.h"
 121 #include "cofexq.h"
 122 c
 123 c 0.2. ==> communs
 124 c
 125 #include "envex1.h"
 126 c
 127 #include "impr02.h"
 128 c
 129 c 0.3. ==> arguments
 130 c
 131       integer typenh, nument
 132       integer cofxeo
 133       integer nbinfx, nctfen, nbenti
 134       integer notfen, nofaen, cofaen(notfen,nofaen)
 135       integer nbfae0, nbfaen, cfaent(nctfen,nbfae0)
 136 c
 137       integer fament(nbenti), posent(nbenti), inxent(nbinfx,nbenti)
 138 c
 139       integer ulsort, langue, codret
 140 c
 141 c 0.4. ==> variables locales
 142 c
 143       integer iaux, jaux, kaux
 144       integer lentit, entdeb
 145       integer caract(100)
 146       integer nufaex
 147       integer posmax
 148 c
 149       integer nbmess
 150       parameter ( nbmess = 10 )
 151       character*80 texte(nblang,nbmess)
 152 c
 153 c 0.5. ==> initialisations
 154 c ______________________________________________________________________
 155 c
 156 c====
 157 c 1. messages
 158 c====
 159 c
 160 #include "impr01.h"
 161 c
 162 #ifdef _DEBUG_HOMARD_
 163       write (ulsort,texte(langue,1)) 'Entree', nompro
 164       call dmflsh (iaux)
 165 #endif
 166 c
 167 #include "impr03.h"
 168 c
 169       texte(1,4) = '(''Familles d''''extrusion des '',a)'
 170 c
 171       texte(2,4) = '(''Description of families of extruded '',a)'
 172 c
 173 #ifdef _DEBUG_HOMARD_
 174       write (ulsort,texte(langue,4)) mess14(langue,3,typenh)
 175       write (ulsort,90002) 'nument', nument
 176       write (ulsort,90002) 'nbinfx', nbinfx
 177       write (ulsort,90002) 'nctfen', nctfen
 178       write (ulsort,90002) 'nbenti', nbenti
 179       write (ulsort,90002) 'notfen', notfen
 180       write (ulsort,90002) 'nofaen', nofaen
 181       write (ulsort,90002) 'nbfae0', nbfae0
 182       write (ulsort,90002) 'nbfaen', nbfaen
 183 #endif
 184 c
 185 #ifdef _DEBUG_HOMARD_
 186 49900 format(33x,a)
 187       write (ulsort,*)
 188      >      'Informations d''extrusion des ', mess14(langue,3,typenh)
 189       if ( typenh.eq.-1 ) then
 190         write(ulsort,49900) ' famille fa noe ex  fa arete'
 191       elseif ( typenh.eq.1 ) then
 192         write(ulsort,49900)
 193      > ' famille fa are ex   fa quad code q/vo face perp'
 194       elseif ( typenh.eq.2 ) then
 195         write(ulsort,49900) 'famille fa tri ex   fa pent code t/pe'
 196       else
 197         write(ulsort,49900)
 198      >  'famille  position fa qua ex   fa hexa code q/vo'
 199       endif
 200       do 4991 , lentit = 1 , nbenti
 201         if ( posent(lentit).eq.0 ) then
 202           write(ulsort,90012)
 203      >                mess14(langue,2,typenh),lentit,fament(lentit),
 204      >                (inxent(jaux,lentit),jaux=1,nbinfx)
 205         endif
 206  4991 continue
 207       write (ulsort,*) 'Codes des familles d''origine des ',
 208      >                 mess14(langue,3,typenh)
 209       do 5991 , iaux = 1 , nofaen
 210         write(ulsort,90012) 'Famille origine', iaux,
 211      >                      (cofaen(jaux,iaux),jaux=1,notfen)
 212  5991 continue
 213 #endif
 214 c
 215       codret = 0
 216 c
 217 c====
 218 c 2. Creation des premieres familles, libres
 219 c    Dans l'ordre : famille a l'avant, a l'arriere, perpendiculaire
 220 c====
 221 #ifdef _DEBUG_HOMARD_
 222       write (ulsort,90002) '2. famille libre ; codret', codret
 223 #endif
 224 c
 225       if ( nbfaen.eq.0 ) then
 226 c
 227         if ( typenh.eq.-1 .or. typenh.eq.2 ) then
 228           kaux = 2
 229         else
 230           kaux = 3
 231         endif
 232 c
 233         do 21 , iaux = 1 , kaux
 234 c
 235 c 2.1. ==> La famille libre de base
 236 c
 237           nbfaen = nbfaen + 1
 238           do 211 , jaux = 1 , notfen
 239             cfaent(jaux,nbfaen) = cofaen(jaux,1)
 240   211     continue
 241 c
 242           if ( iaux.eq.1 ) then
 243             do 2121 , jaux = notfen+1 , nctfen-1
 244               cfaent(jaux,nbfaen) = 1
 245  2121       continue
 246           else
 247             do 2122 , jaux = notfen+1 , nctfen-1
 248               cfaent(jaux,nbfaen) = 0
 249  2122       continue
 250           endif
 251 c
 252 c         Pour les faces, on met un code 1 pour la relation
 253 c         avec les volumes
 254           if ( typenh.ge.2 ) then
 255             cfaent(cofxeo,nbfaen) = 1
 256           endif
 257 c
 258 c         Pour les quadrangles, on met un code 1 pour la 1ere
 259 c         composante de la normale
 260           if ( typenh.ge.4 ) then
 261             cfaent(cofxqt,nbfaen) = 1
 262           endif
 263 c
 264 c         Position
 265           cfaent(nctfen,nbfaen) = iaux-1
 266 cgn          write (ulsort,90002) '.. Creation de la famille libre', nbfaen
 267 cgn          write (ulsort,90005) '.. avec',
 268 cgn     >                         (cfaent(jaux,nbfaen),jaux=1,nctfen)
 269 c
 270    21   continue
 271 c
 272       endif
 273 c
 274 c====
 275 c 3. Parcours des entites
 276 c====
 277 #ifdef _DEBUG_HOMARD_
 278       write (ulsort,90002) '3. parcours ; codret', codret
 279 #endif
 280 c
 281       if ( typenh.le.1 ) then
 282         posmax = 0
 283       elseif ( typenh.eq.2 ) then
 284         posmax = 1
 285       else
 286         posmax = 2
 287       endif
 288 cgn      write (ulsort,90002) 'posmax', posmax
 289 c
 290       entdeb = nument + 1
 291       do 30 , lentit = entdeb, nbenti
 292 c
 293         if ( posent(lentit).le.posmax ) then
 294 cgn      write (ulsort,90012) '. Famille du '//mess14(langue,1,typenh),
 295 cgn     >                     lentit, fament(lentit)
 296 cgn      write (ulsort,90002) '.. position', posent(lentit)
 297 c
 298 c 3.1. ==> Les caracteristiques de l'entite courante
 299 c 3.1.1. ==> On commence par les caracteristiques d'origine
 300 c            de la famille de l'entite courante
 301 c
 302           do 311 , iaux = 1 , notfen
 303             caract(iaux) = cofaen(iaux,fament(lentit))
 304   311     continue
 305 c
 306 c 3.1.2. ==> On complete par les proprietes de l'extrusion
 307 c            Remarque : dans le cas des aretes, la derniere information,
 308 c                       code de la face perpendiculaire dans le volume,
 309 c                       est ecrasee par la position. Elle sera utilisee
 310 c                       plus tard
 311 c
 312           do 312 , iaux = 1 , nbinfx
 313             caract(notfen+iaux) = inxent(iaux,lentit)
 314   312     continue
 315 c
 316 c 3.1.3. ==> Position de l'entite
 317 c
 318           caract(nctfen) = posent(lentit)
 319 cgn      write (ulsort,90005) 'Caract.',(caract(iaux),iaux=1,nctfen)
 320 c
 321 c 3.2. ==> Recherche d'une situation analogue
 322 c
 323           do 32 , iaux = 1 , nbfaen
 324 c
 325             do 321 , jaux = 1 , nctfen
 326               if ( cfaent(jaux,iaux).ne.caract(jaux) ) then
 327                 goto 32
 328               endif
 329   321       continue
 330 c
 331             nufaex = iaux
 332 cgn            write (ulsort,90002) '.. Correspond a la famille', nufaex
 333             goto 34
 334 c
 335    32     continue
 336 c
 337 c 3.3. ==> Creation d'une nouvelle famille
 338 c 3.3.1. ==> S'il n'y a plus de places, on sort et on recommencera
 339 c            pour cette famille
 340 c
 341           if ( nbfaen.ge.nbfae0-1 ) then
 342 c
 343             nument = lentit - 1
 344             nbfaen = -nbfaen
 345             goto 3999
 346 c
 347 c 3.3.2. ==> Creation
 348 c
 349           else
 350 c
 351 c 3.3.2.1. ==> La famille avec les memes caracteristiques
 352 c
 353             nbfaen = nbfaen + 1
 354 cgn         write (ulsort,90002) '.. Creation de la famille', nbfaen
 355 cgn         write (ulsort,90005) '.. avec',(caract(iaux),iaux=1,nctfen)
 356             do 3321 , iaux = 1 , nctfen
 357               cfaent(iaux,nbfaen) = caract(iaux)
 358  3321       continue
 359             nufaex = nbfaen
 360 c
 361 c 3.3.2.2. ==> Pour les aretes, la famille avec l'orientation inverse
 362 c
 363             if ( typenh.eq.1 ) then
 364 c
 365             if ( cfaent(coorfa,nbfaen).ne.0 ) then
 366 c
 367                 nbfaen = nbfaen + 1
 368 cgn         write (ulsort,90015) '.. Creation de la famille', nbfaen,
 369 cgn     >                        ' d''orientation opposee'
 370                 do 3322 , iaux = 1 , nctfen
 371                   cfaent(iaux,nbfaen) = caract(iaux)
 372  3322           continue
 373                 cfaent(coorfa,nbfaen) = -cfaent(coorfa,nbfaen-1)
 374                 cfaent(cofifa,nbfaen  ) = nbfaen-1
 375                 cfaent(cofifa,nbfaen-1) = nbfaen
 376 c
 377               else
 378 c
 379                 cfaent(cofifa,nbfaen) = nbfaen
 380 c
 381               endif
 382 c
 383             endif
 384 c
 385           endif
 386 c
 387 c 3.4. ==> Enregistrement de la nouvelle famille pour l'entite
 388 c
 389    34     continue
 390 c
 391           fament(lentit) = nufaex
 392 c
 393         endif
 394 c
 395    30 continue
 396 c
 397  3999 continue
 398 c
 399 #ifdef _DEBUG_HOMARD_
 400       write (ulsort,90002) 'A la sortie de '//nompro//', nbfaen', nbfaen
 401       if ( typenh.eq.4 ) then
 402       write (ulsort,*) '... Codes des familles des ',
 403      >                 mess14(langue,3,typenh)
 404       do 5992 , iaux = 1 , abs(nbfaen)
 405         write(ulsort,90022) 'Famille', iaux,
 406      >                      (cfaent(jaux,iaux),jaux=1,nctfen)
 407  5992 continue
 408       endif
 409 #endif
 410 c
 411 c====
 412 c 4. la fin
 413 c====
 414 c
 415       if ( codret.ne.0 ) then
 416 c
 417 #include "envex2.h"
 418 c
 419       write (ulsort,texte(langue,1)) 'Sortie', nompro
 420       write (ulsort,texte(langue,2)) codret
 421 c
 422       endif
 423 c
 424 #ifdef _DEBUG_HOMARD_
 425       write (ulsort,texte(langue,1)) 'Sortie', nompro
 426       call dmflsh (iaux)
 427 #endif
 428 c
 429       end