src/tool/AP_Conversion/pcsohe.F

   1       subroutine pcsohe ( typint, deraff,
   2      >                    nbpara, carenf, carchf, nrfonc,
   3      >                    coonoe,
   4      >                    somare,
   5      >                    aretri,
   6      >                    arequa,
   7      >                    tritet, cotrte, aretet,
   8      >                    quahex, coquhe, arehex,
   9      >                    facpyr, cofapy, arepyr,
  10      >                    hethex, anchex, filhex, fhpyte,
  11      >                    nbanhe, anfihe, anhehe, anpthe,
  12      >                    nheeca, nhesca,
  13      >                    nteeca, ntesca,
  14      >                    npyeca, npysca,
  15      >                    ulsort, langue, codret )
  16 c ______________________________________________________________________
  17 c
  18 c                             H O M A R D
  19 c
  20 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  21 c
  22 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  23 c aupres des huissiers de justice Simart et Lavoir a Clamart
  24 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  25 c aupres des huissiers de justice
  26 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  27 c
  28 c    HOMARD est une marque deposee d'Electricite de France
  29 c
  30 c Copyright EDF 1996
  31 c Copyright EDF 1998
  32 c Copyright EDF 2002
  33 c Copyright EDF 2020
  34 c ______________________________________________________________________
  35 c
  36 c    aPres adaptation - Conversion de Solution - HExaedres
  37 c     -                 -             -          --
  38 c ______________________________________________________________________
  39 c .        .     .        .                                            .
  40 c .  nom   . e/s . taille .           description                      .
  41 c .____________________________________________________________________.
  42 c . typint . e   .   1    . type d'interpolation                       .
  43 c .        .     .        .  0, si automatique                         .
  44 c .        .     .        .  elements : 0 si intensif, sans orientation.
  45 c .        .     .        .             1 si extensif, sans orientation.
  46 c .        .     .        .             2 si intensif, avec orientation.
  47 c .        .     .        .             3 si extensif, avec orientation.
  48 c .        .     .        .  noeuds : 1 si degre 1                     .
  49 c .        .     .        .           2 si degre 2                     .
  50 c .        .     .        .           3 si iso-P2                      .
  51 c . deraff . e   .    1   . vrai, s'il y a eu du deraffinement en      .
  52 c .        .     .        . passant de l'iteration n a n+1 ; faux sinon.
  53 c . nbpara . e   .   1    . nombre de parametres a enregistrer par fonc.
  54 c . carenf .   s .nbpara* . caracteristiques entieres des fonctions :  .
  55 c .        .     .  nnfopa.  1 : 0, pour une fonction ancienne isolee  .
  56 c .        .     .        .      1, pour une ancienne associee a une   .
  57 c .        .     .        .         autre fonction                     .
  58 c .        .     .        .      -1, pour une nouvelle fonction        .
  59 c .        .     .        .  2 : typcha                                .
  60 c .        .     .        .  3 : typgeo                                .
  61 c .        .     .        .  4 : nbtyas                                .
  62 c .        .     .        .  5 : ngauss                                .
  63 c .        .     .        .  6 : nnenmx                                .
  64 c .        .     .        .  7 : n1vapr                                .
  65 c .        .     .        .  8 : carsup                                .
  66 c .        .     .        .  9 : nbtafo                                .
  67 c .        .     .        . 10 : anvale                                .
  68 c .        .     .        . 11 : anvalr                                .
  69 c .        .     .        . 12 : anobch                                .
  70 c .        .     .        . 13 : anprpg                                .
  71 c .        .     .        . 14 : anlipr                                .
  72 c .        .     .        . 15 : npenm1                                .
  73 c .        .     .        . 16 : npvap1                                .
  74 c .        .     .        . 17 : apvale                                .
  75 c .        .     .        . 18 : apvalr                                .
  76 c .        .     .        . 19 : apobch                                .
  77 c .        .     .        . 20 : apprpg                                .
  78 c .        .     .        . 21 : apvatt                                .
  79 c .        .     .        . 22 : apvane                                .
  80 c .        .     .        . 23 : antyas                                .
  81 c .        .     .        . 24 : aptyas                                .
  82 c .        .     .        . 25 : numero de la 1ere fonction associee   .
  83 c .        .     .        . 26 : numero de la 2nde fonction associee   .
  84 c . carchf . es  .nbpara* . caracteristiques caracteres des fonctions :.
  85 c .        .     .  nnfopa.  1 : nom de la fonction                    .
  86 c .        .     .        .  2 : nom de la fonction n associee         .
  87 c .        .     .        .  3 : nom de la fonction p associee         .
  88 c .        .     .        .  4 : obpc1n                                .
  89 c .        .     .        .  5 : obpc1p                                .
  90 c .        .     .        .  6 : obpro1                                .
  91 c .        .     .        .  7 : oblo1g                                .
  92 c .        .     .        .  8 : si aux points de Gauss, nom de la     .
  93 c .        .     .        .      fonction n ELNO correspondante        .
  94 c .        .     .        .  9 : si aux points de Gauss, nom de la     .
  95 c .        .     .        .      fonction p ELNO correspondante        .
  96 c . nrfonc . e   .   1    . numero de la fonction principale           .
  97 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  98 c .        .     . * sdim .                                            .
  99 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
 100 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
 101 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
 102 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
 103 c . cotrte . e   .nbtecf*4. code des 4 triangles des tetraedres        .
 104 c . aretet . e   .nbteca*6. numeros des 6 aretes des tetraedres        .
 105 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
 106 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
 107 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
 108 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
 109 c . cofapy . e   .nbpycf*5. codes des faces des pyramides              .
 110 c . arepyr . e   .nbpyca*8. numeros des 8 aretes des pyramides         .
 111 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
 112 c . filhex . e   . nbheto . premier fils des hexaedres                 .
 113 c . fhpyte . e   .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide   .
 114 c .        .     .        . fille de l'hexaedre k tel que filhex(k) =-j.
 115 c .        .     .        . fhpyte(2,j) = numero du 1er tetraedre      .
 116 c .        .     .        . fils de l'hexaedre k tel que filhex(k) = -j.
 117 c . nbanhe . e   .   1    . nombre de hexaedres decoupes par           .
 118 c .        .     .        . conformite sur le maillage avant adaptation.
 119 c . anfihe . e   . nbanhe . tableau filhex du maillage de l'iteration n.
 120 c . anhehe . e   . nbanhe . tableau hethex du maillage de l'iteration n.
 121 c . anpthe . e   .  2**   . tableau fhpyte du maillage de l'iteration n.
 122 c . nheeca . e   .    *   . numero des hexaedres dans le calcul entree .
 123 c . nhesca . e   . rsheto . numero des hexaedres dans le calcul sortie .
 124 c . nteeca . e   .    *   . numero des tetraedres dans le calcul entree.
 125 c . ntesca . e   . rsteto . numero des tetraedres dans le calcul sortie.
 126 c . npyeca . e   .    *   . numero des pyramides dans le calcul entree .
 127 c . npysca . e   . rspyto . numero des pyramides dans le calcul sortie .
 128 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 129 c . langue . e   .    1   . langue des messages                        .
 130 c .        .     .        . 1 : francais, 2 : anglais                  .
 131 c . codret . es  .    1   . code de retour des modules                 .
 132 c .        .     .        . 0 : pas de probleme                        .
 133 c .        .     .        . 1 : probleme                               .
 134 c ______________________________________________________________________
 135 c
 136 c====
 137 c 0. declarations et dimensionnement
 138 c====
 139 c
 140 c 0.1. ==> generalites
 141 c
 142       implicit none
 143       save
 144 c
 145       character*6 nompro
 146       parameter ( nompro = 'PCSOHE' )
 147 c
 148 #include "nblang.h"
 149 #include "consts.h"
 150 #include "meddc0.h"
 151 c
 152 c 0.2. ==> communs
 153 c
 154 #include "envex1.h"
 155 #include "impr02.h"
 156 c
 157 #include "gmenti.h"
 158 #include "gmreel.h"
 159 c
 160 #include "envca1.h"
 161 #include "nombsr.h"
 162 #include "nomber.h"
 163 #include "nombno.h"
 164 #include "nombar.h"
 165 #include "nombtr.h"
 166 #include "nombqu.h"
 167 #include "nombte.h"
 168 #include "nombhe.h"
 169 #include "nombpy.h"
 170 c
 171 c 0.3. ==> arguments
 172 c
 173       integer typint
 174       integer nbpara
 175       integer carenf(nbpara,*)
 176       integer nrfonc
 177 c
 178       integer somare(2,nbarto)
 179       integer aretri(nbtrto,3)
 180       integer arequa(nbquto,4)
 181       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
 182       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
 183       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
 184 c
 185       integer hethex(nbheto), anchex(*)
 186       integer filhex(nbheto), fhpyte(2,nbheco)
 187       integer nbanhe, anfihe(nbanhe), anhehe(nbanhe), anpthe(2,*)
 188 c
 189       integer nheeca(reheto), nhesca(rsheto)
 190       integer nteeca(reteto), ntesca(rsteto)
 191       integer npyeca(repyto), npysca(rspyto)
 192 c
 193       double precision coonoe(nbnoto,sdim)
 194 c
 195       character*8 carchf(nbpara,*)
 196 c
 197       logical deraff
 198 c
 199       integer ulsort, langue, codret
 200 c
 201 c 0.4. ==> variables locales
 202 c
 203       integer iaux, jaux
 204 c
 205       integer typfon, typcha, typgeo, nbtyas
 206       integer ngauss, nnenmx, n1vapr, carsup, nbtafo
 207       integer n1vale, n1valr, n1obpr, n1obch, n1lipr
 208       integer npenm1, npvap1
 209       integer p1vale, p1valr, p1obpr, p1obch, p1vatt
 210       integer p1vane, p1tyas
 211 c
 212       integer nrfon2
 213       integer typfo2, typch2, typge2, typas2
 214       integer ngaus2, nnenm2, nnvap2, carsu2, nbtaf2
 215       integer n2vale, n2valr, n2obpr, n2obch, n2lipr
 216       integer npenm2, npvap2
 217       integer p2vale, p2valr, p2obpr, p2obch, p2vatt
 218       integer p2vane, p2tyas
 219 c
 220       integer nrfon3
 221       integer typfo3, typch3, typge3, typas3
 222       integer ngaus3, nnenm3, nnvap3, carsu3, nbtaf3
 223       integer n3vale, n3valr, n3obpr, n3obch, n3lipr
 224       integer npenm3, npvap3
 225       integer p3vale, p3valr, p3obpr, p3obch, p3vatt
 226       integer p3vane, p3tyas
 227 c
 228       integer adpc1n, adpc1p
 229       integer adpc2n, adpc2p
 230       integer adpc3n, adpc3p
 231 c
 232       character*8 nofon1, obpc1n, obpc1p, obpro1, oblo1g
 233       character*8 nofon2, obpc2n, obpc2p, obpro2, oblo2g
 234       character*8 nofon3, obpc3n, obpc3p, obpro3, oblo3g
 235 c
 236       integer nbmess
 237       parameter ( nbmess = 10 )
 238       character*80 texte(nblang,nbmess)
 239 c
 240 c 0.5. ==> initialisations
 241 c ______________________________________________________________________
 242 c
 243 c====
 244 c 1. initialisations
 245 c====
 246 c
 247 #include "impr01.h"
 248 c
 249 #ifdef _DEBUG_HOMARD_
 250       write (ulsort,texte(langue,1)) 'Entree', nompro
 251       call dmflsh (iaux)
 252 #endif
 253 c
 254 #include "pcimp1.h"
 255 #include "impr03.h"
 256 c
 257 #ifdef _DEBUG_HOMARD_
 258       write (ulsort,texte(langue,4)) nrfonc
 259 #endif
 260 c
 261 c====
 262 c 2. grandeurs utiles
 263 c====
 264 c
 265 c 2.1. ==> la fonction de base
 266 c
 267       if ( codret.eq.0 ) then
 268 #ifdef _DEBUG_HOMARD_
 269       write(ulsort,90002) 'carenf',(carenf(iaux,nrfonc),iaux= 1,10)
 270       write(ulsort,90002) 'carenf',(carenf(iaux,nrfonc),iaux=11,20)
 271       write(ulsort,90002) 'carenf',(carenf(iaux,nrfonc),iaux=21,nbpara)
 272       write(ulsort,90003) 'carchf',(carchf(iaux,nrfonc),iaux= 1,9)
 273 #endif
 274 c
 275 #ifdef _DEBUG_HOMARD_
 276       write (ulsort,texte(langue,3)) 'PCFOR2', nompro
 277 #endif
 278       iaux = nrfonc
 279       call pcfor2 ( nbpara, carenf, carchf,
 280      >              iaux,
 281      >              typfon, typcha, typgeo, nbtyas,
 282      >              ngauss, nnenmx, n1vapr, carsup, nbtafo,
 283      >              n1vale, n1valr, n1obpr, n1obch, n1lipr,
 284      >              npenm1, npvap1,
 285      >              p1vale, p1valr, p1obpr, p1obch, p1vatt,
 286      >              p1vane, p1tyas,
 287      >              nrfon2, nrfon3,
 288      >              nofon1,
 289      >              obpc1n, obpc1p, obpro1, adpc1n, adpc1p,
 290      >              oblo1g,
 291      >              ulsort, langue, codret )
 292 c
 293       endif
 294 c
 295 #ifdef _DEBUG_HOMARD_
 296       if ( codret.eq.0 ) then
 297       write (ulsort,90003) 'nofon1', nofon1
 298       write (ulsort,90002) 'typfon', typfon
 299       write (ulsort,90002) 'typcha', typcha
 300       write (ulsort,90002) 'typgeo', typgeo
 301       write (ulsort,90002) 'nbtyas', nbtyas
 302       write (ulsort,90002) 'carsup', carsup
 303       write (ulsort,90002) 'nbtafo', nbtafo
 304       write (ulsort,90002) 'ngauss', ngauss
 305       write (ulsort,90002) 'nrfon2', nrfon2
 306       write (ulsort,90002) 'nrfon3', nrfon3
 307       write (ulsort,90003) 'oblo1g', oblo1g
 308       endif
 309 #endif
 310 c
 311 c 2.2. ==> les fonctions annexes
 312 c 2.2.1. ==> tetraedres
 313 c
 314       if ( nrfon2.gt.0 ) then
 315 c
 316         if ( codret.eq.0 ) then
 317 c
 318 #ifdef _DEBUG_HOMARD_
 319       write (ulsort,texte(langue,4)) nrfon2
 320       write(ulsort,90002) 'carenf',(carenf(iaux,nrfon2),iaux= 1,10)
 321       write(ulsort,90002) 'carenf',(carenf(iaux,nrfon2),iaux=11,20)
 322       write(ulsort,90002) 'carenf',(carenf(iaux,nrfon2),iaux=21,nbpara)
 323       write(ulsort,90003) 'carchf',(carchf(iaux,nrfon2),iaux= 1,9)
 324 #endif
 325 #ifdef _DEBUG_HOMARD_
 326       write (ulsort,texte(langue,3)) 'PCFOR2_te', nompro
 327 #endif
 328         call pcfor2 ( nbpara, carenf, carchf,
 329      >                nrfon2,
 330      >                typfo2, typch2, typge2, typas2,
 331      >                ngaus2, nnenm2, nnvap2, carsu2, nbtaf2,
 332      >                n2vale, n2valr, n2obpr, n2obch, n2lipr,
 333      >                npenm2, npvap2,
 334      >                p2vale, p2valr, p2obpr, p2obch, p2vatt,
 335      >                p2vane, p2tyas,
 336      >                iaux, jaux,
 337      >                nofon2,
 338      >                obpc2n, obpc2p, obpro2, adpc2n, adpc2p,
 339      >                oblo2g,
 340      >                ulsort, langue, codret )
 341 c
 342 #ifdef _DEBUG_HOMARD_
 343       if ( codret.eq.0 ) then
 344       write (ulsort,90003) 'nofon2', nofon2
 345       write (ulsort,90002) 'typfo2', typfo2
 346       write (ulsort,90002) 'typch2', typch2
 347       write (ulsort,90002) 'typge2', typge2
 348       write (ulsort,90002) 'typas2', typas2
 349       write (ulsort,90002) 'carsu2', carsu2
 350       write (ulsort,90002) 'ngaus2', ngaus2
 351 c      write (ulsort,90003) 'oblo2g', oblo2g
 352       endif
 353 #endif
 354 c
 355         endif
 356 c
 357       endif
 358 c
 359 c 2.2.2. ==> pyramides
 360 c
 361       if ( nrfon3.gt.0 ) then
 362 c
 363         if ( codret.eq.0 ) then
 364 c
 365 #ifdef _DEBUG_HOMARD_
 366       write (ulsort,texte(langue,4)) nrfon3
 367       write(ulsort,90002) 'carenf',(carenf(iaux,nrfon3),iaux= 1,10)
 368       write(ulsort,90002) 'carenf',(carenf(iaux,nrfon3),iaux=11,20)
 369       write(ulsort,90002) 'carenf',(carenf(iaux,nrfon3),iaux=21,nbpara)
 370       write(ulsort,90003) 'carchf',(carchf(iaux,nrfon3),iaux= 1,9)
 371 #endif
 372 #ifdef _DEBUG_HOMARD_
 373       write (ulsort,texte(langue,3)) 'PCFOR2_py', nompro
 374 #endif
 375         call pcfor2 ( nbpara, carenf, carchf,
 376      >                nrfon3,
 377      >                typfo3, typch3, typge3, typas3,
 378      >                ngaus3, nnenm3, nnvap3, carsu3, nbtaf3,
 379      >                n3vale, n3valr, n3obpr, n3obch, n3lipr,
 380      >                npenm3, npvap3,
 381      >                p3vale, p3valr, p3obpr, p3obch, p3vatt,
 382      >                p3vane, p3tyas,
 383      >                iaux, jaux,
 384      >                nofon3,
 385      >                obpc3n, obpc3p, obpro3, adpc3n, adpc3p,
 386      >                oblo3g,
 387      >                ulsort, langue, codret )
 388 c
 389 #ifdef _DEBUG_HOMARD_
 390       if ( codret.eq.0 ) then
 391       write (ulsort,90003) 'nofon3', nofon3
 392       write (ulsort,90002) 'typfo3', typfo3
 393       write (ulsort,90002) 'typch3', typch3
 394       write (ulsort,90002) 'typge3', typge3
 395       write (ulsort,90002) 'typas3', typas3
 396       write (ulsort,90002) 'carsu3', carsu3
 397       write (ulsort,90002) 'ngaus3', ngaus3
 398 c      write (ulsort,90003) 'oblo3g', oblo3g
 399       endif
 400 #endif
 401 c
 402         endif
 403 c
 404       endif
 405 c
 406 c====
 407 c 3. interpolation des variables
 408 c====
 409 c
 410 c 3.1. ==> sans point de Gauss
 411 c
 412       if ( ngauss.eq.ednopg ) then
 413 c
 414         if ( codret.eq.0 ) then
 415 c
 416 #ifdef _DEBUG_HOMARD_
 417         write (ulsort,texte(langue,3)) 'PCSHE0', nompro
 418 #endif
 419         call pcshe0 ( nbtafo, typint, deraff,
 420      >                imem(adpc1n), imem(adpc1p),
 421      >                coonoe,
 422      >                somare,
 423      >                aretri,
 424      >                arequa,
 425      >                tritet, cotrte, aretet,
 426      >                quahex, coquhe, arehex,
 427      >                facpyr, cofapy, arepyr,
 428      >                hethex, anchex, filhex, fhpyte,
 429      >                nbanhe, anfihe, anpthe,
 430      >                nheeca, nhesca,
 431      >                nteeca, ntesca,
 432      >                npyeca, npysca,
 433      >                rmem(n1valr), rmem(p1vatt),
 434      >                rmem(n2valr), rmem(p2vatt),
 435      >                imem(adpc2n), imem(adpc2p),
 436      >                rmem(n3valr), rmem(p3vatt),
 437      >                imem(adpc3n), imem(adpc3p),
 438      >                ulsort, langue, codret )
 439 c
 440         endif
 441 cgn      write(ulsort,*) 'hexa'
 442 cgn      if ( nbhexa.eq.8 ) then
 443 cgn         codret=67
 444 cgn      else
 445 cgn         codret=178
 446 cgn      endif
 447 cgn      write(ulsort,3000) (rmem(p1vatt+codret+iaux),iaux=0,nbheto-1)
 448 cgn      write(ulsort,*) 'hexr'
 449 cgn      write(ulsort,3000) (rmem(p2vatt+iaux),iaux=0,nbhexa-1)
 450 cgn      write(ulsort,*) 'pyra'
 451 cgn      if ( nbhexa.eq.8 ) then
 452 cgn         codret=75
 453 cgn      else
 454 cgn         codret=225
 455 cgn      endif
 456 cgn      write(ulsort,3000) (rmem(p3vatt+codret+iaux),iaux=0,nbpyto-1)
 457 cgn 3000 format(10g13.5)
 458 cgn       codret = 0
 459 c
 460       else
 461 c
 462 c 3.2. ==> avec plusieurs points de Gauss
 463 c
 464 c 3.2.1. ==> champ aux noeuds par element
 465 c
 466         if ( carsup.eq.1 ) then
 467 c
 468           if ( codret.eq.0 ) then
 469 c
 470           write (ulsort,texte(langue,8)) mess14(langue,1,6)
 471           write (ulsort,texte(langue,10))
 472           codret = 321
 473 c
 474           endif
 475 c
 476 c
 477           if ( codret.eq.0 ) then
 478 c
 479 #ifdef _DEBUG_HOMARD_
 480       write (ulsort,texte(langue,3)) 'PCEHE1', nompro
 481 #endif
 482           call pcehe1 ( nbtafo, ngauss, deraff,
 483      >                  imem(adpc1n), imem(adpc1p),
 484      >                  hethex, anchex, filhex, fhpyte,
 485      >                  nbanhe, anfihe, anhehe, anpthe,
 486      >                  nheeca, nhesca,
 487      >                  nteeca, ntesca,
 488      >                  npyeca, npysca,
 489      >                  rmem(n1valr), rmem(p1vatt),
 490      >                  ulsort, langue, codret )
 491 c
 492           endif
 493 c
 494 c 3.2.2. ==> vrai champ aux points de Gauss
 495 c
 496         else
 497 c
 498           if ( codret.eq.0 ) then
 499 c
 500           write (ulsort,texte(langue,9)) mess14(langue,1,6)
 501           write (ulsort,texte(langue,10))
 502           codret = 322
 503 c
 504           endif
 505 c
 506         endif
 507 c
 508       endif
 509 cgn      print *, 'codret = ', codret
 510 c
 511 c====
 512 c 4. la fin
 513 c====
 514 c
 515       if ( codret.ne.0 ) then
 516 c
 517 #include "envex2.h"
 518 c
 519       write (ulsort,texte(langue,1)) 'Sortie', nompro
 520       write (ulsort,texte(langue,2)) codret
 521 c
 522       endif
 523 c
 524 #ifdef _DEBUG_HOMARD_
 525       write (ulsort,texte(langue,1)) 'Sortie', nompro
 526       call dmflsh (iaux)
 527 #endif
 528 c
 529       end