src/tool/AP_Conversion/pcs2pe.F

   1       subroutine pcs2pe ( nbfop2, profho, vap2ho,
   2      >                    hetpen, facpen, cofape, filpen, fppyte,
   3      >                    somare, np2are,
   4      >                    aretri, arequa,
   5      >                    tritet, cotrte,
   6      >                    facpyr, cofapy,
   7      >                    ulsort, langue, codret )
   8 c ______________________________________________________________________
   9 c
  10 c                             H O M A R D
  11 c
  12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  13 c
  14 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  15 c aupres des huissiers de justice Simart et Lavoir a Clamart
  16 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  17 c aupres des huissiers de justice
  18 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  19 c
  20 c    HOMARD est une marque deposee d'Electricite de France
  21 c
  22 c Copyright EDF 1996
  23 c Copyright EDF 1998
  24 c Copyright EDF 2002
  25 c Copyright EDF 2020
  26 c ______________________________________________________________________
  27 c
  28 c    aPres adaptation - Conversion de Solution -
  29 c     -                 -             -
  30 c    interpolation p2 sur les noeuds - decoupage des PEntaedres
  31 c                  -                                 --
  32 c remarque : on devrait optimiser cela car si le pentaedre etait dans
  33 c            un etat de decoupage similaire, on recalcule une valeur
  34 c            qui est deja presente
  35 c remarque : pcs2pe et pcsipe sont des clones
  36 c ______________________________________________________________________
  37 c .        .     .        .                                            .
  38 c .  nom   . e/s . taille .           description                      .
  39 c .____________________________________________________________________.
  40 c . nbfop2 . e   .    1   . nombre de fonctions P2                     .
  41 c . profho . es  .   *    . pour chaque entite en numerotation homard :.
  42 c .        .     .        . 0 : l'entite est absente du profil         .
  43 c .        .     .        . 1 : l'entite est presente dans le profil   .
  44 c . vap2ho . es  . nbfop2*. variables p1 numerotation homard           .
  45 c .        .     . nbnoto .                                            .
  46 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  47 c . facpen . e   .nbpecf*5. numeros des faces des pentaedres           .
  48 c . cofape . e   .nbpecf*5. codes des faces des pentaedres             .
  49 c . filpen . e   . nbpeto . premier fils des pentaedres                .
  50 c . fppyte . e   .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide   .
  51 c .        .     .        . fille du pentaedre k tel que filpen(k) =-j .
  52 c .        .     .        . fppyte(2,j) = numero du 1er tetraedre      .
  53 c .        .     .        . fils du pentaedre k tel que filpen(k) = -j .
  54 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  55 c . np2are . e   . nbarto . numero des noeuds p2 milieux d'aretes      .
  56 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  57 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  58 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  59 c . cotrte . e   .nbtecf*4. code des 4 triangles des tetraedres        .
  60 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  61 c . cofapy . e   .nbpycf*5. codes des 5 faces des pyramides            .
  62 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  63 c . langue . e   .    1   . langue des messages                        .
  64 c .        .     .        . 1 : francais, 2 : anglais                  .
  65 c . codret . es  .    1   . code de retour des modules                 .
  66 c .        .     .        . 0 : pas de probleme                        .
  67 c .        .     .        . 1 : probleme                               .
  68 c ______________________________________________________________________
  69 c
  70 c====
  71 c 0. declarations et dimensionnement
  72 c====
  73 c
  74 c 0.1. ==> generalites
  75 c
  76       implicit none
  77       save
  78 c
  79       character*6 nompro
  80       parameter ( nompro = 'PCS2PE' )
  81 c
  82 #include "envex1.h"
  83 #include "nblang.h"
  84 #include "fractb.h"
  85 #include "fractk.h"
  86 c
  87 c 0.2. ==> communs
  88 c
  89 #include "nombar.h"
  90 #include "nombtr.h"
  91 #include "nombqu.h"
  92 #include "nombte.h"
  93 #include "nombpy.h"
  94 #include "nombpe.h"
  95 c
  96 c 0.3. ==> arguments
  97 c
  98       integer nbfop2
  99       integer profho(*)
 100       integer hetpen(nbpeto), facpen(nbpecf,5), cofape(nbpecf,5)
 101       integer filpen(nbpeto), fppyte(2,nbpeco)
 102       integer somare(2,nbarto), np2are(nbarto)
 103       integer aretri(nbtrto,3)
 104       integer arequa(nbquto,4)
 105       integer tritet(nbtecf,4), cotrte(nbtecf,4)
 106       integer facpyr(nbpycf,5), cofapy(nbpycf,5)
 107 c
 108       double precision vap2ho(nbfop2,*)
 109 c
 110       integer ulsort, langue, codret
 111 c
 112 c 0.4. ==> variables locales
 113 c
 114       integer iaux, jaux
 115       integer lepent
 116       integer typdec, typd00
 117       integer etanp1
 118       integer sm, nuv
 119       integer listar(9), listno(15)
 120       integer nbarco
 121       integer nuaret(15)
 122 c
 123       logical afaire
 124 c
 125       double precision daux
 126 c
 127       integer nbmess
 128       parameter ( nbmess = 10 )
 129       character*80 texte(nblang,nbmess)
 130 c ______________________________________________________________________
 131 c
 132 c====
 133 c 1. initialisations
 134 c====
 135 c
 136 c 1.1. ==> messages
 137 c
 138 #include "impr01.h"
 139 c
 140 #ifdef _DEBUG_HOMARD_
 141       write (ulsort,texte(langue,1)) 'Entree', nompro
 142       call dmflsh (iaux)
 143 #endif
 144 c
 145 #include "impr03.h"
 146 c
 147       codret = 0
 148 c
 149       do 100 , jaux = 1, nbpeto
 150 c
 151         lepent = jaux
 152 c
 153 c====
 154 c 2. recherche des types d'interpolations a faire
 155 c====
 156 c
 157         if ( codret.eq.0 ) then
 158 c
 159 #ifdef _DEBUG_HOMARD_
 160         write(ulsort,texte(langue,3)) 'PCS0PE', nompro
 161 #endif
 162         call pcs0pe ( lepent, profho,
 163      >                hetpen, facpen, cofape, filpen, fppyte,
 164      >                somare, np2are,
 165      >                aretri, arequa,
 166      >                tritet, cotrte,
 167      >                facpyr, cofapy,
 168      >                afaire, listar, listno, typdec, etanp1, sm )
 169 cgn      write(ulsort,90002) 'typdec',typdec
 170 c
 171         endif
 172 c
 173         if ( afaire ) then
 174 c
 175 c====
 176 c 3. L'eventuel noeud central
 177 c       decoupage selon 2 aretes tria/tria
 178 c       decoupage selon 1 face traingulaire
 179 c====
 180 c
 181         if ( codret.eq.0 ) then
 182 c
 183         if ( mod(typdec,2).eq.0 ) then
 184 c
 185           profho(sm) = 1
 186 c
 187 c         formule p2 :
 188 c         interpolation = -2/9(u1+...+u6)
 189 c                       + 2/9(u7+...+u12)+ 1/3(u13+...+u15)
 190 c
 191           do 31 , nuv = 1, nbfop2
 192 c
 193             daux = 0.d0
 194             do 311 , iaux = 1 , 6
 195               daux = daux - vap2ho(nuv,listno(iaux))
 196   311       continue
 197             do 312 , iaux = 7 , 12
 198               daux = daux + vap2ho(nuv,listno(iaux))
 199   312       continue
 200             vap2ho(nuv,sm) = desne * daux +
 201      >                       unstr * ( vap2ho(nuv,listno(13)) +
 202      >                                 vap2ho(nuv,listno(14)) +
 203      >                                 vap2ho(nuv,listno(15)) )
 204 cgn        write(ulsort,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm)
 205 c
 206    31     continue
 207 c
 208           typdec = typdec/2
 209 c
 210         endif
 211 c
 212         endif
 213 c
 214 c====
 215 c 4. Recuperation des aretes internes
 216 c====
 217 c
 218   40    continue
 219 cgn        write(ulsort,90002) 'typdec',typdec
 220 c
 221         if ( codret.eq.0 ) then
 222 c
 223         iaux = 1
 224 c
 225         if ( mod(typdec,3).eq.0 ) then
 226           typd00 = 3
 227         elseif ( mod(typdec,5).eq.0 ) then
 228           iaux = 3
 229           typd00 = 5
 230         elseif ( mod(typdec,7).eq.0 ) then
 231           iaux = 2
 232           typd00 = 7
 233         elseif ( mod(typdec,11).eq.0 ) then
 234           typd00 = 11
 235         elseif ( mod(typdec,13).eq.0 ) then
 236           typd00 = 13
 237         elseif ( mod(typdec,17).eq.0 ) then
 238           typd00 = 17
 239         endif
 240 c
 241 c 4.4. ==> Les aretes
 242 c
 243 #ifdef _DEBUG_HOMARD_
 244         write(ulsort,texte(langue,3)) 'UTAIPE', nompro
 245 #endif
 246         call utaipe ( lepent, iaux,
 247      >                hetpen, facpen, filpen, fppyte,
 248      >                aretri,
 249      >                tritet, cotrte,
 250      >                nbarco, nuaret,
 251      >                ulsort, langue, codret )
 252 c
 253         endif
 254 c
 255 c====
 256 c 5. D'un milieu de faces a un autre
 257 c    (decoupage en 8)
 258 c====
 259 c
 260         if ( codret.eq.0 ) then
 261 c
 262         if ( mod(typdec,3).eq.0 ) then
 263 c
 264 #ifdef _DEBUG_HOMARD_
 265         write(ulsort,texte(langue,3)) 'PCS2P1', nompro
 266 #endif
 267           call pcs2p1 ( nbfop2, profho, vap2ho,
 268      >                  np2are,
 269      >                  listno, listno(7),
 270      >                  nbarco, nuaret )
 271 c
 272         endif
 273 c
 274         endif
 275 c
 276 c====
 277 c 6. Du centre aux milieux d'aretes
 278 c    (selon 2 aretes tri ou 1 face tri)
 279 c====
 280 c
 281         if ( codret.eq.0 ) then
 282 c
 283         if ( mod(typdec,5).eq.0 ) then
 284 c
 285 #ifdef _DEBUG_HOMARD_
 286         write(ulsort,texte(langue,3)) 'PCS2P2', nompro
 287 #endif
 288           call pcs2p2 ( nbfop2, profho, vap2ho,
 289      >                  np2are,
 290      >                  etanp1,
 291      >                  listno, listno(7),
 292      >                  nbarco, nuaret )
 293 c
 294         endif
 295 c
 296         endif
 297 c
 298 c====
 299 c 7. Du centre aux sommets
 300 c    (selon 2 aretes tri ou 1 face tri)
 301 c====
 302 c
 303         if ( codret.eq.0 ) then
 304 c
 305         if ( mod(typdec,7).eq.0 ) then
 306 c
 307 #ifdef _DEBUG_HOMARD_
 308         write(ulsort,texte(langue,3)) 'PCS2P3', nompro
 309 #endif
 310           call pcs2p3 ( nbfop2, profho, vap2ho,
 311      >                  np2are,
 312      >                  etanp1,
 313      >                  listno, listno(7),
 314      >                  nbarco, nuaret )
 315 c
 316         endif
 317 c
 318         endif
 319 c
 320 c====
 321 c 6. D'un milieu d'arete a un autre
 322 c    (selon 2 aretes tria+quad)
 323 c====
 324 c
 325         if ( codret.eq.0 ) then
 326 c
 327         if ( mod(typdec,11).eq.0 ) then
 328 c
 329 #ifdef _DEBUG_HOMARD_
 330         write(ulsort,texte(langue,3)) 'PCS2P4', nompro
 331 #endif
 332           call pcs2p4 ( nbfop2, profho, vap2ho,
 333      >                  np2are,
 334      >                  etanp1,
 335      >                  listno, listno(7),
 336      >                  nbarco, nuaret )
 337 c
 338         endif
 339 c
 340         endif
 341 c
 342 c====
 343 c 7. D'un milieu d'arete a un sommet
 344 c    (selon 1 arete tri)
 345 c====
 346 c
 347         if ( codret.eq.0 ) then
 348 c
 349         if ( mod(typdec,13).eq.0 ) then
 350 c
 351 #ifdef _DEBUG_HOMARD_
 352         write(ulsort,texte(langue,3)) 'PCS2P5', nompro
 353 #endif
 354           call pcs2p5 ( nbfop2, profho, vap2ho,
 355      >                  np2are,
 356      >                  etanp1,
 357      >                  listno, listno(7),
 358      >                  nbarco, nuaret )
 359 c
 360         endif
 361 c
 362         endif
 363 c
 364 c====
 365 c 8. D'un milieu de face a un sommet
 366 c    (selon 1 face quad)
 367 c====
 368 c
 369         if ( codret.eq.0 ) then
 370 c
 371         if ( mod(typdec,17).eq.0 ) then
 372 c
 373 #ifdef _DEBUG_HOMARD_
 374         write(ulsort,texte(langue,3)) 'PCS2P6', nompro
 375 #endif
 376           call pcs2p6 ( nbfop2, profho, vap2ho,
 377      >                  np2are,
 378      >                  etanp1,
 379      >                  listno, listno(7),
 380      >                  nbarco, nuaret )
 381 c
 382         endif
 383 c
 384         endif
 385 c
 386 c====
 387 c 9. Encore ?
 388 c====
 389 c
 390         typdec = typdec/typd00
 391         if ( typdec.gt.1 ) then
 392           goto 40
 393         endif
 394 c
 395         endif
 396 c
 397   100 continue
 398 c
 399 c====
 400 c 10. la fin
 401 c====
 402 c
 403       if ( codret.ne.0 ) then
 404 c
 405 #include "envex2.h"
 406 c
 407       write (ulsort,texte(langue,1)) 'Sortie', nompro
 408       write (ulsort,texte(langue,2)) codret
 409 c
 410       endif
 411 c
 412 #ifdef _DEBUG_HOMARD_
 413       write (ulsort,texte(langue,1)) 'Sortie', nompro
 414       call dmflsh (iaux)
 415 #endif
 416 c
 417       end