src/tool/AP_Conversion/pcmape.F

   1       subroutine pcmape ( elemen, nbele0,
   2      >                    somare, np2are,
   3      >                    arequa,
   4      >                    facpen, cofape, arepen,
   5      >                    hetpen, fampen, cfapen,
   6      >                    nnosca, npesca, npesho,
   7      >                    famele, noeele, typele,
   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                                   Coperight EDF 1997, 1998, 1999, 2002
  24 c ______________________________________________________________________
  25 c
  26 c
  27 c    aPres adaptation - Conversion - MAillage connectivite - PEntaedres
  28 c     -                 -            --                      --
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . elemen . es  .   1    . numero du dernier element cree             .
  34 c . nbele0 . e   .   1    . estimation du nombre d'elements            .
  35 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  36 c . np2are . e   . nbarto . numero du noeud p2 milieu d'arete          .
  37 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  38 c . facpen . e   .nbpecf*5. numeros des faces des pentaedres           .
  39 c . cofape . e   .nbpecf*5. codes des faces des pentaedres             .
  40 c . arepen . e   .nbpeca*9. numeros des 9 aretes des pentaedres        .
  41 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  42 c . fampen . e   . nbpeto . famille des pentaedres                     .
  43 c . cfapen .     . nctfhe. codes des familles des pentaedres           .
  44 c .        .     . nbfpen .   1 : famille MED                          .
  45 c .        .     .        .   2 : type d'pentaedres                    .
  46 c . nnosca . e   . rsnoto . numero des noeuds du code de calcul        .
  47 c . npesca .  s  . rspeto . numero des pentaedres dans le calcul       .
  48 c . npesho .  s  . nbele0 . numero des pentaedres dans HOMARD          .
  49 c . famele . es  . nbele0 . famille med des elements                   .
  50 c . noeele . es  . nbele0 . noeuds des elements                        .
  51 c .        .     . *nbmane.                                            .
  52 c . typele . es  . nbele0 . type des elements                          .
  53 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  54 c . langue . e   .    1   . langue des messages                        .
  55 c .        .     .        . 1 : francais, 2 : anglais                  .
  56 c . codret . es  .    1   . code de retour des modules                 .
  57 c .        .     .        . 0 : pas de probleme                        .
  58 c .        .     .        . 1 : probleme                               .
  59 c ______________________________________________________________________
  60 c
  61 c====
  62 c 0. declarations et dimensionnement
  63 c====
  64 c
  65 c 0.1. ==> generalites
  66 c
  67       implicit none
  68       save
  69 c
  70       character*6 nompro
  71       parameter ( nompro = 'PCMAPE' )
  72 c
  73 #include "nblang.h"
  74 #include "coftex.h"
  75 c
  76 c 0.2. ==> communs
  77 c
  78 #include "envex1.h"
  79 c
  80 #include "impr02.h"
  81 #include "envca1.h"
  82 c
  83 #include "nbfami.h"
  84 #include "nombar.h"
  85 #include "nombqu.h"
  86 #include "nombpe.h"
  87 c
  88 #include "nombsr.h"
  89 c
  90 #include "dicfen.h"
  91 c
  92 c 0.3. ==> arguments
  93 c
  94       integer elemen
  95       integer nbele0
  96 c
  97       integer somare(2,nbarto), np2are(nbarto)
  98       integer arequa(nbquto,4)
  99       integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
 100       integer hetpen(nbpeto)
 101 c
 102       integer cfapen(nctfpe,nbfpen), fampen(nbpeto)
 103 c
 104       integer nnosca(rsnoto)
 105       integer npesca(rspeto), npesho(nbele0)
 106 c
 107       integer famele(nbele0), noeele(nbele0,nbmane)
 108       integer typele(nbele0)
 109 c
 110       integer ulsort, langue, codret
 111 c
 112 c 0.4. ==> variables locales
 113 c
 114       integer lepent, lepen0
 115       integer etat
 116       integer iaux
 117       integer listar(9), listso(15), nomiar(9)
 118 #ifdef _DEBUG_HOMARD_
 119       integer glop
 120 #endif
 121 c
 122       integer nbmess
 123       parameter ( nbmess = 20 )
 124       character*80 texte(nblang,nbmess)
 125 c
 126 c 0.5. ==> initialisations
 127 c ______________________________________________________________________
 128 c
 129 c====
 130 c 1. initialisations
 131 c====
 132 c
 133 #include "impr01.h"
 134 c
 135 #ifdef _DEBUG_HOMARD_
 136       write (ulsort,texte(langue,1)) 'Entree', nompro
 137       call dmflsh (iaux)
 138 #endif
 139 c
 140 #ifdef _DEBUG_HOMARD_
 141       write(ulsort,90002) 'nbpecf, nbpeca =', nbpecf, nbpeca
 142 #endif
 143 c
 144 #include "impr03.h"
 145 c
 146 #include "impr06.h"
 147 c
 148 c====
 149 c 2. initialisations des renumerotations
 150 c====
 151 c
 152       do 21 , iaux = 1 , rspeto
 153         npesca(iaux) = 0
 154    21 continue
 155 c
 156       do 22 , iaux = 1 , nbele0
 157         npesho(iaux) = 0
 158    22 continue
 159 c
 160 c====
 161 c 3. Conversion en lineaire
 162 c====
 163 c
 164       if ( degre.eq.1 ) then
 165 c
 166 c          S3                   a9                     S6
 167 c           x------------------------------------------x
 168 c          .                                          .
 169 c         .  .                                       .  .
 170 c     a3 .                                       a6 .
 171 c       .     .                                    .     .
 172 c      .                                          .
 173 c     .        .a1                               .        .a4
 174 c    .                                          .
 175 c S2.           .       a8                   S5.           .
 176 c  x------------------------------------------x
 177 c     .          .                               .          .
 178 c          .                                          .
 179 c        a2    .  .                                 a5    .  .
 180 c                  x------------------------------------------x
 181 c                 S1                   a7                     S4
 182 c   La face f1 est le triangle (S1,S2,S3).
 183 c   La face f2 est le triangle (S4,S6,S5).
 184 c   La face fi, 3<=i<=5, est le quadrangle s'appuyant sur l'arete ai-2.
 185 c
 186         do 31 , lepen0 = 1 , nbpeto
 187 c
 188           lepent = lepen0
 189 c
 190 #ifdef _DEBUG_HOMARD_
 191       write (ulsort,texte(langue,11)) mess14(langue,2,7), lepent
 192 #endif
 193 c
 194           etat = mod( hetpen(lepent) , 100 )
 195 c
 196           if ( etat.eq.0 .or. hierar.ne.0 ) then
 197 c
 198             elemen = elemen + 1
 199 #ifdef _DEBUG_HOMARD_
 200         if ( elemen.eq.-12 ) then
 201           glop = 1
 202         else
 203           glop = 0
 204         endif
 205 #endif
 206 #ifdef _DEBUG_HOMARD_
 207         if ( glop.ne.0 ) then
 208             write (ulsort,texte(langue,14)) elemen
 209         endif
 210 #endif
 211             npesho(elemen) = lepent
 212             npesca(lepent) = elemen
 213 c
 214             call utaspe ( lepent,
 215      >                    nbquto, nbpecf, nbpeca,
 216      >                    somare, arequa,
 217      >                    facpen, cofape, arepen,
 218      >                    listar, listso )
 219 c
 220 c     Attention : utaspe donne la numerotation dans la convention homard
 221 c                 il faut permuter les sommets 2/3 et 5/6 pour obtenir
 222 c                 la numerotation dans la convention med
 223 c
 224             noeele(elemen,1) = nnosca(listso(1))
 225             noeele(elemen,2) = nnosca(listso(3))
 226             noeele(elemen,3) = nnosca(listso(2))
 227             noeele(elemen,4) = nnosca(listso(4))
 228             noeele(elemen,5) = nnosca(listso(6))
 229             noeele(elemen,6) = nnosca(listso(5))
 230 c
 231             famele(elemen) = cfapen(cofamd,fampen(lepent))
 232             typele(elemen) = cfapen(cotyel,fampen(lepent))
 233 c
 234 #ifdef _DEBUG_HOMARD_
 235             if ( glop.ne.0 ) then
 236             write (ulsort,90002) 'fampen', fampen(lepent)
 237             write (ulsort,texte(langue,14)) elemen
 238             write (ulsort,texte(langue,15))
 239      >             (noeele(elemen,iaux),iaux=1,6)
 240             write (ulsort,90002) 'Famille MED',famele(elemen)
 241             write (ulsort,90002) 'Type MED   ',typele(elemen)
 242             endif
 243 #endif
 244 c
 245           endif
 246 c
 247   31   continue
 248 c
 249 c====
 250 c 4. Conversion en quadratique
 251 c====
 252 c
 253       else
 254 c
 255 c          S3                   a9/N14                 S6
 256 c           x------------------------------------------x
 257 c          .                                          .
 258 c         .  .                                       .  .
 259 c     a3 .                                       a6 .
 260 c     N8.     .                                 N11.     .
 261 c      .                                          .
 262 c     .        .a1                               .        .a4
 263 c    .          N7                              .           N10
 264 c S2.           .       a8/N15               S5.           .
 265 c  x------------------------------------------x
 266 c     .          .                               .          .
 267 c          .                                      N12 .
 268 c        a2    .  .                                 a5    .  .
 269 c        N9        x------------------------------------------x
 270 c                 S1                   a7/N13                 S4
 271 c   La face f1 est le triangle (S1,S2,S3).
 272 c   La face f2 est le triangle (S4,S6,S5).
 273 c   La face fi, 3<=i<=5, est le quadrangle s'appuyant sur l'arete ai-2.
 274 c
 275 c            Au sens homard      au sens MED
 276 c          arete  1 de s1 a s3 | de s1 a s2
 277 c          arete  2 de s1 a s2 | de s1 a s3
 278 c          arete  3 de s2 a s3 | de s2 a s3
 279 c          arete  4 de s4 a s6 | de s4 a s5
 280 c          arete  5 de s4 a s5 | de s4 a s6
 281 c          arete  6 de s5 a s6 | de s5 a s6
 282 c          arete  7 de s1 a s4 | de s1 a s4
 283 c          arete  8 de s2 a s5 | de s3 a s6
 284 c          arete  9 de s3 a s6 | de s2 a s5
 285 c       Tableau de travail nomiar :
 286 c       nomiar(i) contient le numero local au sens MED du noeud porte
 287 c       par l'arete de numero local i au sens homard
 288 c
 289         nomiar( 1) =  7
 290         nomiar( 2) =  9
 291         nomiar( 3) =  8
 292         nomiar( 4) = 10
 293         nomiar( 5) = 12
 294         nomiar( 6) = 11
 295         nomiar( 7) = 13
 296         nomiar( 8) = 15
 297         nomiar( 9) = 14
 298 c
 299         do 41 , lepen0 = 1 , nbpeto
 300 c
 301           lepent = lepen0
 302 c
 303 #ifdef _DEBUG_HOMARD_
 304         if ( elemen.eq.-12 ) then
 305           glop = 1
 306         else
 307           glop = 0
 308         endif
 309 #endif
 310 c
 311 #ifdef _DEBUG_HOMARD_
 312       write (ulsort,texte(langue,11)) mess14(langue,2,7), lepent
 313 #endif
 314 c
 315           etat = mod( hetpen(lepent) , 100 )
 316 c
 317           if ( etat.eq.0 .or. hierar.ne.0 ) then
 318 c
 319             elemen = elemen + 1
 320 #ifdef _DEBUG_HOMARD_
 321         if ( glop.ne.0 ) then
 322             write (ulsort,texte(langue,14)) elemen
 323         endif
 324 #endif
 325             npesho(elemen) = lepent
 326             npesca(lepent) = elemen
 327 cgn      write (ulsort,555) 'tria', (facpen(lepent,iaux),iaux=1,2)
 328 cgn      write (ulsort,555) 'quad',facpen(lepent,3),cofape(lepent,3)
 329 cgn      write (ulsort,555) '-> ',(arequa(facpen(lepent,3),iaux),iaux=1,4)
 330 cgn      write (ulsort,555) 'quad',facpen(lepent,4),cofape(lepent,4)
 331 cgn      write (ulsort,555) '-> ',(arequa(facpen(lepent,4),iaux),iaux=1,4)
 332 cgn      write (ulsort,555) 'quad',facpen(lepent,5),cofape(lepent,5)
 333 cgn      write (ulsort,555) '-> ',(arequa(facpen(lepent,5),iaux),iaux=1,4)
 334 c
 335             call utaspe ( lepent,
 336      >                    nbquto, nbpecf, nbpeca,
 337      >                    somare, arequa,
 338      >                    facpen, cofape, arepen,
 339      >                    listar, listso )
 340 c
 341 c     Attention : utaspe donne la numerotation dans la convention homard
 342 c                 il faut permuter les sommets 2/3 et 5/6 pour obtenir
 343 c                 la numerotation dans la convention med
 344 c
 345 cgn      write (ulsort,555) 'listso',(listso(iaux),iaux=1,6)
 346             noeele(elemen,1) = nnosca(listso(1))
 347             noeele(elemen,2) = nnosca(listso(3))
 348             noeele(elemen,3) = nnosca(listso(2))
 349             noeele(elemen,4) = nnosca(listso(4))
 350             noeele(elemen,5) = nnosca(listso(6))
 351             noeele(elemen,6) = nnosca(listso(5))
 352 cgn      write (ulsort,555) '--> so',(noeele(elemen,iaux),iaux=1,6)
 353 c
 354 c     Les noeuds au milieu des aretes
 355 c
 356             do 411 , iaux = 1 , 9
 357               noeele(elemen,nomiar(iaux)) = nnosca(np2are(listar(iaux)))
 358   411       continue
 359 cgn      write (ulsort,555) 'p2',(noeele(elemen,nomiar(iaux)),iaux=1,9)
 360 c
 361 cgn  555 format(a,10i3)
 362             famele(elemen) = cfapen(cofamd,fampen(lepent))
 363             typele(elemen) = cfapen(cotyel,fampen(lepent))
 364 c
 365           endif
 366 c
 367   41   continue
 368 c
 369       endif
 370 c
 371 c====
 372 c 5. la fin
 373 c====
 374 c
 375       if ( codret.ne.0 ) then
 376 c
 377 #include "envex2.h"
 378 c
 379       write (ulsort,texte(langue,1)) 'Sortie', nompro
 380       write (ulsort,texte(langue,2)) codret
 381 c
 382       endif
 383 c
 384 #ifdef _DEBUG_HOMARD_
 385       write (ulsort,texte(langue,1)) 'Sortie', nompro
 386       call dmflsh (iaux)
 387 #endif
 388 c
 389       end