src/tool/AP_Conversion/pcsote.F

   1       subroutine pcsote ( typint, deraff,
   2      >                    nbpara, carenf, carchf, nrfonc,
   3      >                    hettet, anctet, filtet,
   4      >                    nbante, anfite, anhete,
   5      >                    nteeca, ntesca,
   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    aPres adaptation - Conversion de Solution - TEtraedres
  28 c     -                 -             -          --
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . typint . e   .   1    . type d'interpolation                       .
  34 c .        .     .        .  0, si automatique                         .
  35 c .        .     .        .  elements : 0 si intensif, sans orientation.
  36 c .        .     .        .             1 si extensif, sans orientation.
  37 c .        .     .        .             2 si intensif, avec orientation.
  38 c .        .     .        .             3 si extensif, avec orientation.
  39 c .        .     .        .  noeuds : 1 si degre 1                     .
  40 c .        .     .        .           2 si degre 2                     .
  41 c .        .     .        .           3 si iso-P2                      .
  42 c . deraff . e   .    1   . vrai, s'il y a eu du deraffinement en      .
  43 c .        .     .        . passant de l'iteration n a n+1 ; faux sinon.
  44 c . nbpara . e   .   1    . nombre de parametres a enregistrer par fonc.
  45 c . carenf .   s .nbpara* . caracteristiques entieres des fonctions :  .
  46 c .        .     .  nnfopa.  1 : 0, pour une fonction ancienne isolee  .
  47 c .        .     .        .      1, pour une ancienne associee a une   .
  48 c .        .     .        .         autre fonction                     .
  49 c .        .     .        .      -1, pour une nouvelle fonction        .
  50 c .        .     .        .  2 : typcha                                .
  51 c .        .     .        .  3 : typgeo                                .
  52 c .        .     .        .  4 : typass                                .
  53 c .        .     .        .  5 : ngauss                                .
  54 c .        .     .        .  6 : nnenmx                                .
  55 c .        .     .        .  7 : nnvapr                                .
  56 c .        .     .        .  8 : carsup                                .
  57 c .        .     .        .  9 : nbtafo                                .
  58 c .        .     .        . 10 : anvale                                .
  59 c .        .     .        . 11 : anvalr                                .
  60 c .        .     .        . 12 : anobch                                .
  61 c .        .     .        . 13 : anprpg                                .
  62 c .        .     .        . 14 : anlipr                                .
  63 c .        .     .        . 15 : npenmx                                .
  64 c .        .     .        . 16 : npvapr                                .
  65 c .        .     .        . 17 : apvale                                .
  66 c .        .     .        . 18 : apvalr                                .
  67 c .        .     .        . 19 : apobch                                .
  68 c .        .     .        . 20 : apprpg                                .
  69 c .        .     .        . 21 : apvatt                                .
  70 c .        .     .        . 22 : apvane                                .
  71 c .        .     .        . 23 : antyas                                .
  72 c .        .     .        . 24 : aptyas                                .
  73 c .        .     .        . 25 : numero de la 1ere fonction associee   .
  74 c .        .     .        . 26 : numero de la 2nde fonction associee   .
  75 c . carchf . es  .nbpara* . caracteristiques caracteres des fonctions :.
  76 c .        .     .  nnfopa.  1 : nom de la fonction                    .
  77 c .        .     .        .  2 : nom de la fonction n associee         .
  78 c .        .     .        .  3 : nom de la fonction p associee         .
  79 c .        .     .        .  4 : obpcan                                .
  80 c .        .     .        .  5 : obpcap                                .
  81 c .        .     .        .  6 : obprof                                .
  82 c .        .     .        .  7 : oblo1g                                .
  83 c .        .     .        .  8 : si aux points de Gauss, nom de la     .
  84 c .        .     .        .      fonction n ELNO correspondante        .
  85 c .        .     .        .  9 : si aux points de Gauss, nom de la     .
  86 c .        .     .        .      fonction p ELNO correspondante        .
  87 c . nrfonc . e   .   1    . numero de la fonction principale           .
  88 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  89 c . filtet . e   . nbteto . premier fils des tetraedres                .
  90 c . nbante . e   .   1    . nombre de tetraedres decoupes par          .
  91 c .        .     .        . conformite sur le maillage avant adaptation.
  92 c . anfite . e   . nbante . tableau filtet du maillage de l'iteration n.
  93 c . anhete . e   . nbante . tableau hettet du maillage de l'iteration n.
  94 c . nteeca . e   .    *   . tetraedres en entree dans le calcul        .
  95 c . ntesca . e   . rsteto . tetraedres en sortie dans le calcul        .
  96 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  97 c . langue . e   .    1   . langue des messages                        .
  98 c .        .     .        . 1 : francais, 2 : anglais                  .
  99 c . codret . es  .    1   . code de retour des modules                 .
 100 c .        .     .        . 0 : pas de probleme                        .
 101 c .        .     .        . 1 : probleme                               .
 102 c ______________________________________________________________________
 103 c
 104 c====
 105 c 0. declarations et dimensionnement
 106 c====
 107 c
 108 c 0.1. ==> generalites
 109 c
 110       implicit none
 111       save
 112 c
 113       character*6 nompro
 114       parameter ( nompro = 'PCSOTE' )
 115 c
 116 #include "nblang.h"
 117 #include "consts.h"
 118 #include "meddc0.h"
 119 c
 120 c 0.2. ==> communs
 121 c
 122 #include "envex1.h"
 123 c
 124 #include "envca1.h"
 125 #include "gmenti.h"
 126 #include "gmreel.h"
 127 c
 128 #include "nombte.h"
 129 #include "nombsr.h"
 130 #include "nomber.h"
 131 c
 132 c 0.3. ==> arguments
 133 c
 134       integer typint
 135       integer nbpara
 136       integer carenf(nbpara,*)
 137       integer nrfonc
 138 c
 139       integer hettet(nbteto), anctet(*)
 140       integer filtet(nbteto)
 141       integer nbante, anfite(nbante), anhete(nbante)
 142 c
 143       integer nteeca(reteto), ntesca(rsteto)
 144 c
 145       character*8 carchf(nbpara,*)
 146 c
 147       logical deraff
 148 c
 149       integer ulsort, langue, codret
 150 c
 151 c 0.4. ==> variables locales
 152 c
 153       integer iaux
 154 c
 155       integer typfon, typcha, typgeo, typass
 156       integer ngauss, nnenmx, nnvapr, carsup, nbtafo
 157       integer n1vale, n1valr, n1obpr, n1obch, n1lipr
 158       integer npenmx, npvapr
 159       integer p1vale, p1valr, p1obpr, p1obch, p1vatt
 160       integer p1vane, p1tyas
 161       integer adpcan, adpcap
 162       integer nrfon2, nrfon3
 163       integer nbnorf
 164       integer adcono, adcopg, adpopg, adwipg
 165       integer dimcpg
 166 c
 167       character*8 nofonc, obpcan, obpcap, obprof
 168       character*8 oblo1g
 169       character*8 ntrava
 170       character*64 nolopg
 171 c
 172       integer nbmess
 173       parameter ( nbmess = 10 )
 174       character*80 texte(nblang,nbmess)
 175 c
 176 c 0.5. ==> initialisations
 177 c ______________________________________________________________________
 178 c
 179 c====
 180 c 1. initialisations
 181 c====
 182 c
 183 c 1.1. ==> messages
 184 c
 185 #include "impr01.h"
 186 c
 187 #ifdef _DEBUG_HOMARD_
 188       write (ulsort,texte(langue,1)) 'Entree', nompro
 189       call dmflsh (iaux)
 190 #endif
 191 c
 192 #include "pcimp1.h"
 193 #include "impr03.h"
 194 c
 195 #ifdef _DEBUG_HOMARD_
 196       write (ulsort,texte(langue,4)) nrfonc
 197 #endif
 198 c
 199 c====
 200 c 2. grandeurs utiles
 201 c====
 202 c
 203       if ( codret.eq.0 ) then
 204 c
 205 #ifdef _DEBUG_HOMARD_
 206       write(ulsort,90002) 'carenf  ',(carenf(iaux,nrfonc),iaux= 1,10)
 207       write(ulsort,90002) 'carenf  ',(carenf(iaux,nrfonc),iaux=11,20)
 208       write(ulsort,90002) 'carenf  ',
 209      >                    (carenf(iaux,nrfonc),iaux=21,nbpara)
 210       write(ulsort,90003) 'carchf  ',(carchf(iaux,nrfonc),iaux= 1,9)
 211 #endif
 212 #ifdef _DEBUG_HOMARD_
 213       write (ulsort,texte(langue,3)) 'PCFOR2', nompro
 214 #endif
 215       iaux = nrfonc
 216       call pcfor2 ( nbpara, carenf, carchf,
 217      >              iaux,
 218      >              typfon, typcha, typgeo, typass,
 219      >              ngauss, nnenmx, nnvapr, carsup, nbtafo,
 220      >              n1vale, n1valr, n1obpr, n1obch, n1lipr,
 221      >              npenmx, npvapr,
 222      >              p1vale, p1valr, p1obpr, p1obch, p1vatt,
 223      >              p1vane, p1tyas,
 224      >              nrfon2, nrfon3,
 225      >              nofonc,
 226      >              obpcan, obpcap, obprof, adpcan, adpcap,
 227      >              oblo1g,
 228      >              ulsort, langue, codret )
 229 c
 230       endif
 231 c
 232
 233 #ifdef _DEBUG_HOMARD_
 234       if ( codret.eq.0 ) then
 235       write (ulsort,90003) 'nofonc', nofonc
 236       write (ulsort,90002) 'typfon', typfon
 237       write (ulsort,90002) 'typcha', typcha
 238       write (ulsort,90002) 'typgeo', typgeo
 239       write (ulsort,90002) 'typass', typass
 240       write (ulsort,90002) 'carsup', carsup
 241       write (ulsort,90002) 'nbtafo', nbtafo
 242       write (ulsort,90002) 'ngauss', ngauss
 243       write (ulsort,90003) 'oblo1g', oblo1g
 244       endif
 245 #endif
 246 c
 247 c====
 248 c 3. interpolation des variables
 249 c====
 250 c
 251 c 3.1. ==> sans point de Gauss
 252 c
 253       if ( ngauss.eq.ednopg ) then
 254 c
 255         if ( codret.eq.0 ) then
 256 c
 257 #ifdef _DEBUG_HOMARD_
 258       write (ulsort,texte(langue,3)) 'PCSTE0', nompro
 259 #endif
 260 cgn        print *,(rmem(n1valr+iaux-1),iaux=1,5)
 261         call pcste0 ( nbtafo, typint, deraff,
 262      >                imem(adpcan), imem(adpcap),
 263      >                hettet, anctet, filtet,
 264      >                nbante, anfite,
 265      >                nteeca, ntesca,
 266      >                rmem(n1valr), rmem(p1vatt),
 267      >                ulsort, langue, codret )
 268 c
 269         endif
 270 cgn        print *,(rmem(p1vatt+iaux-1),iaux=1,18)
 271 c
 272       else
 273 c
 274 c 3.2. ==> avec plusieurs points de Gauss
 275 c
 276 c 3.2.1. ==> champ aux noeuds par element
 277 c
 278         if ( carsup.eq.1 ) then
 279 c
 280           if ( codret.eq.0 ) then
 281 c
 282 #ifdef _DEBUG_HOMARD_
 283       write (ulsort,texte(langue,3)) 'PCETE1', nompro
 284 #endif
 285           call pcete1 ( nbtafo, ngauss, deraff,
 286      >                  imem(adpcan), imem(adpcap),
 287      >                  hettet, anctet, filtet,
 288      >                  nbante, anfite, anhete,
 289      >                  nteeca, ntesca,
 290      >                  rmem(n1valr), rmem(p1vatt),
 291      >                  ulsort, langue, codret )
 292 c
 293           endif
 294 c
 295 c 3.2.2. ==> vrai champ aux points de Gauss
 296 c
 297         else
 298 c
 299 c 3.2.2.1. ==> recuperation de la localisation des points de Gauss
 300 c
 301           if ( codret.eq.0 ) then
 302 c
 303 #ifdef _DEBUG_HOMARD_
 304       write (ulsort,texte(langue,3)) 'UTCAPG', nompro
 305 #endif
 306 c
 307           call utcapg ( oblo1g,
 308      >                  nolopg, typgeo, ngauss, dimcpg,
 309      >                  adcono, adcopg, adpopg,
 310      >                  ulsort, langue, codret )
 311 c
 312           if ( degre.eq.1 ) then
 313             nbnorf = 4
 314           else
 315             nbnorf = 10
 316           endif
 317 c
 318           endif
 319 c
 320 c 3.2.2.2. ==> interpolation
 321 c
 322           if ( codret.eq.0 ) then
 323           iaux = ngauss*nbnorf
 324           call gmalot ( ntrava, 'reel    ', iaux, adwipg, codret )
 325           endif
 326 c
 327           if ( codret.eq.0 ) then
 328 c
 329 #ifdef _DEBUG_HOMARD_
 330       write (ulsort,texte(langue,3)) 'PCSTEG', nompro
 331 #endif
 332           call pcsteg ( nbtafo, ngauss, nbnorf, typgeo, deraff,
 333      >                  imem(adpcan), imem(adpcap),
 334      >                  hettet, anctet, filtet,
 335      >                  nbante, anfite,
 336      >                  nteeca, ntesca,
 337      >                  rmem(n1valr), rmem(p1vatt),
 338      >                  rmem(adcono), rmem(adcopg), rmem(adwipg),
 339      >                  ulsort, langue, codret )
 340 c
 341           endif
 342 c
 343           if ( codret.eq.0 ) then
 344           call gmlboj ( ntrava , codret )
 345           endif
 346 c
 347         endif
 348 c
 349       endif
 350 cgn      print *, 'codret = ', codret
 351 c
 352 c====
 353 c 4. la fin
 354 c====
 355 c
 356       if ( codret.ne.0 ) then
 357 c
 358 #include "envex2.h"
 359 c
 360       write (ulsort,texte(langue,1)) 'Sortie', nompro
 361       write (ulsort,texte(langue,2)) codret
 362 c
 363       endif
 364 c
 365 #ifdef _DEBUG_HOMARD_
 366       write (ulsort,texte(langue,1)) 'Sortie', nompro
 367       call dmflsh (iaux)
 368 #endif
 369 c
 370       end