src/tool/AP_Conversion/pcsoar.F

   1       subroutine pcsoar ( typint, deraff,
   2      >                    nbpara, carenf, carchf, nrfonc,
   3      >                    hetare, ancare, filare,
   4      >                    somare,
   5      >                    coonoe,
   6      >                    hettri, aretri, filtri,
   7      >                    hetqua, arequa, filqua,
   8      >                    nbanar, anfiar,
   9      >                    nareca, narsca,
  10      >                    ulsort, langue, codret )
  11 c ______________________________________________________________________
  12 c
  13 c                             H O M A R D
  14 c
  15 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  16 c
  17 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  18 c aupres des huissiers de justice Simart et Lavoir a Clamart
  19 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  20 c aupres des huissiers de justice
  21 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  22 c
  23 c    HOMARD est une marque deposee d'Electricite de France
  24 c
  25 c Copyright EDF 1996
  26 c Copyright EDF 1998
  27 c Copyright EDF 2002
  28 c Copyright EDF 2020
  29 c ______________________________________________________________________
  30 c
  31 c    aPres adaptation - Conversion de Solution - ARetes
  32 c     -                 -             -          --
  33 c ______________________________________________________________________
  34 c .        .     .        .                                            .
  35 c .  nom   . e/s . taille .           description                      .
  36 c .____________________________________________________________________.
  37 c . typint . e   .   1    . type d'interpolation                       .
  38 c .        .     .        .  0, si automatique                         .
  39 c .        .     .        .  elements : 0 si intensif, sans orientation.
  40 c .        .     .        .             1 si extensif, sans orientation.
  41 c .        .     .        .             2 si intensif, avec orientation.
  42 c .        .     .        .             3 si extensif, avec orientation.
  43 c .        .     .        .  noeuds : 1 si degre 1                     .
  44 c .        .     .        .           2 si degre 2                     .
  45 c .        .     .        .           3 si iso-P2                      .
  46 c . deraff . e   .    1   . vrai, s'il y a eu du deraffinement en      .
  47 c .        .     .        . passant de l'iteration n a n+1 ; faux sinon.
  48 c . nbpara . e   .   1    . nombre de parametres a enregistrer par fonc.
  49 c . carenf .   s .nbpara* . caracteristiques entieres des fonctions :  .
  50 c .        .     .  nnfopa.  1 : 0, pour une fonction ancienne isolee  .
  51 c .        .     .        .      1, pour une ancienne associee a une   .
  52 c .        .     .        .         autre fonction                     .
  53 c .        .     .        .      -1, pour une nouvelle fonction        .
  54 c .        .     .        .  2 : typcha                                .
  55 c .        .     .        .  3 : typgeo                                .
  56 c .        .     .        .  4 : typass                                .
  57 c .        .     .        .  5 : ngauss                                .
  58 c .        .     .        .  6 : nnenmx                                .
  59 c .        .     .        .  7 : nnvapr                                .
  60 c .        .     .        .  8 : carsup                                .
  61 c .        .     .        .  9 : nbtafo                                .
  62 c .        .     .        . 10 : anvale                                .
  63 c .        .     .        . 11 : anvalr                                .
  64 c .        .     .        . 12 : anobch                                .
  65 c .        .     .        . 13 : anprpg                                .
  66 c .        .     .        . 14 : anlipr                                .
  67 c .        .     .        . 15 : npenmx                                .
  68 c .        .     .        . 16 : npvapr                                .
  69 c .        .     .        . 17 : apvale                                .
  70 c .        .     .        . 18 : apvalr                                .
  71 c .        .     .        . 19 : apobch                                .
  72 c .        .     .        . 20 : apprpg                                .
  73 c .        .     .        . 21 : apvatt                                .
  74 c .        .     .        . 22 : apvane                                .
  75 c .        .     .        . 23 : antyas                                .
  76 c .        .     .        . 24 : aptyas                                .
  77 c .        .     .        . 25 : numero de la 1ere fonction associee   .
  78 c .        .     .        . 26 : numero de la 2nde fonction associee   .
  79 c . carchf . es  .nbpara* . caracteristiques caracteres des fonctions :.
  80 c .        .     .  nnfopa.  1 : nom de la fonction                    .
  81 c .        .     .        .  2 : nom de la fonction n associee         .
  82 c .        .     .        .  3 : nom de la fonction p associee         .
  83 c .        .     .        .  4 : obpcan                                .
  84 c .        .     .        .  5 : obpcap                                .
  85 c .        .     .        .  6 : obprof                                .
  86 c .        .     .        .  7 : oblopg                                .
  87 c .        .     .        .  8 : si aux points de Gauss, nom de la     .
  88 c .        .     .        .      fonction n ELNO correspondante        .
  89 c .        .     .        .  9 : si aux points de Gauss, nom de la     .
  90 c .        .     .        .      fonction p ELNO correspondante        .
  91 c . nrfonc . e   .   1    . numero de la fonction principale           .
  92 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  93 c . ancare . e   . nbarto . anciens numeros des aretes conservees      .
  94 c . filare . e   . nbarto . fille ainee de chaque arete                .
  95 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  96 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  97 c .        .     . * sdim .                                            .
  98 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  99 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
 100 c . filtri . e   . nbtrto . premier fils des triangles                 .
 101 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
 102 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
 103 c . filqua . e   . nbquto . premier fils des quadrangles               .
 104 c . nareca . e   .   *    . nro des aretes dans le calcul en entree    .
 105 c . narsca . e   . rsarto . numero des aretes du calcul                .
 106 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 107 c . langue . e   .    1   . langue des messages                        .
 108 c .        .     .        . 1 : francais, 2 : anglais                  .
 109 c . codret . es  .    1   . code de retour des modules                 .
 110 c .        .     .        . 0 : pas de probleme                        .
 111 c .        .     .        . 1 : probleme                               .
 112 c ______________________________________________________________________
 113 c
 114 c====
 115 c 0. declarations et dimensionnement
 116 c====
 117 c
 118 c 0.1. ==> generalites
 119 c
 120       implicit none
 121       save
 122 c
 123       character*6 nompro
 124       parameter ( nompro = 'PCSOAR' )
 125 c
 126 #include "nblang.h"
 127 #include "consts.h"
 128 #include "meddc0.h"
 129 c
 130 c 0.2. ==> communs
 131 c
 132 #include "envex1.h"
 133 c
 134 #include "gmreel.h"
 135 #include "gmenti.h"
 136 c
 137 #include "envca1.h"
 138 #include "nomber.h"
 139 #include "nombno.h"
 140 #include "nombar.h"
 141 #include "nombtr.h"
 142 #include "nombqu.h"
 143 #include "nombsr.h"
 144 c
 145 c 0.3. ==> arguments
 146 c
 147       integer typint
 148       integer nbpara
 149       integer carenf(nbpara,*)
 150       integer nrfonc
 151 c
 152       integer hetare(nbarto), ancare(*)
 153       integer filare(nbarto)
 154       integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto)
 155       integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto)
 156       integer nbanar, anfiar(nbanar)
 157       integer somare(2,*)
 158 c
 159       integer nareca(rearto), narsca(rsarto)
 160 c
 161       character*8 carchf(nbpara,*)
 162 c
 163       logical deraff
 164 c
 165       double precision coonoe(nbnoto,sdim)
 166 c
 167       integer ulsort, langue, codret
 168 c
 169 c 0.4. ==> variables locales
 170 c
 171       integer iaux
 172 c
 173       integer typfon, typcha, typgeo, nbtyas
 174       integer ngauss, nnenmx, nnvapr, carsup, nbtafo
 175       integer n1vale, n1valr, n1obpr, n1obch, n1lipr
 176       integer npenmx, npvapr
 177       integer p1vale, p1valr, p1obpr, p1obch, p1vatt
 178       integer p1vane, p1tyas
 179       integer adpcan, adpcap
 180       integer nrfon2, nrfon3
 181 c
 182       character*8 nofonc, obpcan, obpcap, obprof
 183       character*8 oblopg
 184 c
 185 #ifdef _DEBUG_HOMARD_
 186       integer jaux
 187       integer aretes(3)
 188       double precision champ(3), flux, lgaret(3)
 189 #endif
 190 c
 191       integer nbmess
 192       parameter ( nbmess = 10 )
 193       character*80 texte(nblang,nbmess)
 194 c
 195 c 0.5. ==> initialisations
 196 c ______________________________________________________________________
 197 c
 198 c====
 199 c 1. initialisations
 200 c====
 201 c
 202 #include "impr01.h"
 203 #include "impr03.h"
 204 c
 205 #ifdef _DEBUG_HOMARD_
 206       write (ulsort,texte(langue,1)) 'Entree', nompro
 207       call dmflsh (iaux)
 208 #endif
 209 c
 210       codret = 0
 211 c
 212 c====
 213 c 2. grandeurs utiles
 214 c====
 215 c 2.1. ==> recuperation
 216 c
 217       if ( codret.eq.0 ) then
 218 c
 219       iaux = nrfonc
 220 #ifdef _DEBUG_HOMARD_
 221       write (ulsort,texte(langue,3)) 'PCFOR2', nompro
 222 #endif
 223       call pcfor2 ( nbpara, carenf, carchf,
 224      >              iaux,
 225      >              typfon, typcha, typgeo, nbtyas,
 226      >              ngauss, nnenmx, nnvapr, carsup, nbtafo,
 227      >              n1vale, n1valr, n1obpr, n1obch, n1lipr,
 228      >              npenmx, npvapr,
 229      >              p1vale, p1valr, p1obpr, p1obch, p1vatt,
 230      >              p1vane, p1tyas,
 231      >              nrfon2, nrfon3,
 232      >              nofonc,
 233      >              obpcan, obpcap, obprof, adpcan, adpcap,
 234      >              oblopg,
 235      >              ulsort, langue, codret )
 236 c
 237       endif
 238 c
 239 #ifdef _DEBUG_HOMARD_
 240       if ( codret.eq.0 ) then
 241       write (ulsort,90003) 'nofonc', nofonc
 242       write (ulsort,90002) 'typfon', typfon
 243       write (ulsort,90002) 'typcha', typcha
 244       write (ulsort,90002) 'typgeo', typgeo
 245       write (ulsort,90002) 'nbtyas', nbtyas
 246       write (ulsort,90002) 'carsup', carsup
 247       write (ulsort,90002) 'ngauss', ngauss
 248       write (ulsort,90002) 'nbtafo', nbtafo
 249       write (ulsort,90002) 'p1vane', p1vane
 250       endif
 251 #endif
 252 c
 253 c====
 254 c 3. interpolation des variables
 255 c====
 256 #ifdef _DEBUG_HOMARD_
 257       write (ulsort,90002) '3. Interpolation ; codret', codret
 258 #endif
 259 c
 260 c 3.1. ==> sans point de Gauss
 261 c
 262       if ( ngauss.eq.ednopg ) then
 263 c
 264 c 3.1.1. ==> pour les aretes decoupees/reactivees
 265 c
 266         if ( codret.eq.0 ) then
 267 c
 268 #ifdef _DEBUG_HOMARD_
 269       write (ulsort,texte(langue,3)) 'PCSAR0', nompro
 270 #endif
 271         call pcsar0 ( nbtafo, typint, deraff,
 272      >                imem(adpcan), imem(adpcap),
 273      >                hetare, ancare, filare,
 274      >                nbanar, anfiar,
 275      >                nareca, narsca,
 276      >                rmem(n1valr), rmem(p1vatt),
 277      >                ulsort, langue, codret )
 278 c
 279         endif
 280 c
 281 c 3.1.2. ==> pour les triangles decoupes/reactives
 282 c
 283         if ( nbtrma.ne.0 ) then
 284 c
 285           if ( codret.eq.0 ) then
 286 c
 287 #ifdef _DEBUG_HOMARD_
 288       write (ulsort,texte(langue,3)) 'PCSAR1', nompro
 289 #endif
 290           call pcsar1 ( nbtafo, typint, deraff,
 291      >                  imem(adpcan), imem(adpcap),
 292      >                  hetare, ancare, filare,
 293      >                  nbanar, anfiar,
 294      >                  somare,
 295      >                  hettri, aretri, filtri,
 296      >                  nareca, narsca,
 297      >                  rmem(n1valr), rmem(p1vatt),
 298      >                  ulsort, langue, codret )
 299 c
 300         endif
 301 c
 302         endif
 303 c
 304 #ifdef _DEBUG_HOMARD_
 305 c
 306         do 312 , iaux = 1 , nbtrto
 307 c
 308           if ( mod(hettri(iaux),10).eq.0 ) then
 309             write (ulsort,90002) 'Triangle', iaux
 310 c
 311             do 3121 , jaux = 1 , 3
 312               aretes(jaux) = aretri(iaux,jaux)
 313               champ(jaux) = rmem(p1vatt-1+narsca(aretes(jaux)))
 314  3121       continue
 315             jaux = 0
 316             call utfltr ( jaux, coonoe, somare, aretes,
 317      >                    champ, flux, lgaret,
 318      >                    ulsort, langue, codret )
 319             write (ulsort,90024) '==> Flux pour le triangle', iaux, flux
 320 c
 321           endif
 322 c
 323   312   continue
 324         do 3122 , iaux = 1 , nbarto
 325           if ( narsca(iaux).gt.0 ) then
 326             write(ulsort,90014) iaux, rmem(p1vatt-1+narsca(iaux))
 327           endif
 328  3122   continue
 329 cgn        do 3123 , iaux = 1 , nbarto
 330 cgn          if ( narsca(iaux).gt.0 ) then
 331 cgn          write(ulsort,90014) narsca(iaux)-17,
 332 cgn     >                  rmem(p1vatt-1+narsca(iaux))
 333 cgn          endif
 334 cgn 3123   continue
 335 #endif
 336 c
 337       else
 338 c
 339         codret = 8
 340 c
 341       endif
 342 cgn      print *, 'codret = ', codret
 343 c
 344 c====
 345 c 4. la fin
 346 c====
 347 c
 348       if ( codret.ne.0 ) then
 349 c
 350 #include "envex2.h"
 351 c
 352       write (ulsort,texte(langue,1)) 'Sortie', nompro
 353       write (ulsort,texte(langue,2)) codret
 354 c
 355       endif
 356 c
 357 #ifdef _DEBUG_HOMARD_
 358       write (ulsort,texte(langue,1)) 'Sortie', nompro
 359       call dmflsh (iaux)
 360 #endif
 361 c
 362       end