src/tool/AP_Conversion/pcfor2.F

   1       subroutine pcfor2 ( nbpara, carenf, carchf,
   2      >                    nrfonc,
   3      >                    typfon, typcha, typgeo, nbtyas,
   4      >                    ngauss, nnenmx, nnvapr, carsup, nbtafo,
   5      >                    anvale, anvalr, anprpg, anobch, anlipr,
   6      >                    npenmx, npvapr,
   7      >                    apvale, apvalr, apprpg, apobch, apvatt,
   8      >                    apvane, aptyas,
   9      >                    nrfon2, nrfon3,
  10      >                    nofonc,
  11      >                    obpcan, obpcap, obprof, adpcan, adpcap,
  12      >                    oblopg,
  13      >                    ulsort, langue, codret )
  14 c ______________________________________________________________________
  15 c
  16 c                             H O M A R D
  17 c
  18 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  19 c
  20 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  21 c aupres des huissiers de justice Simart et Lavoir a Clamart
  22 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  23 c aupres des huissiers de justice
  24 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  25 c
  26 c    HOMARD est une marque deposee d'Electricite de France
  27 c
  28 c Copyright EDF 1996
  29 c Copyright EDF 1998
  30 c Copyright EDF 2002
  31 c Copyright EDF 2020
  32 c ______________________________________________________________________
  33 c
  34 c    aPres adaptation - Fonctions - Recuperation - phase 2
  35 c     -                 --          -                    -
  36 c ______________________________________________________________________
  37 c .        .     .        .                                            .
  38 c .  nom   . e/s . taille .           description                      .
  39 c .____________________________________________________________________.
  40 c . nbpara . e   .   1    . nombre de parametres a enregistrer par fonc.
  41 c . carenf . e   .nbpara* . caracteristiques entieres des fonctions :  .
  42 c .        .     .  nnfopa.  1 : 0, pour une fonction ancienne isolee  .
  43 c .        .     .        .      1, pour une ancienne associee a une   .
  44 c .        .     .        .         autre fonction                     .
  45 c .        .     .        .      -1, pour une nouvelle fonction        .
  46 c .        .     .        .  2 : typcha                                .
  47 c .        .     .        .  3 : typgeo                                .
  48 c .        .     .        .  4 : nbtyas                                .
  49 c .        .     .        .  5 : ngauss                                .
  50 c .        .     .        .  6 : nnenmx                                .
  51 c .        .     .        .  7 : nnvapr                                .
  52 c .        .     .        .  8 : carsup                                .
  53 c .        .     .        .  9 : nbtafo                                .
  54 c .        .     .        . 10 : anvale                                .
  55 c .        .     .        . 11 : anvalr                                .
  56 c .        .     .        . 12 : anobch                                .
  57 c .        .     .        . 13 : anprpg                                .
  58 c .        .     .        . 14 : anlipr                                .
  59 c .        .     .        . 15 : npenmx                                .
  60 c .        .     .        . 16 : npvapr                                .
  61 c .        .     .        . 17 : apvale                                .
  62 c .        .     .        . 18 : apvalr                                .
  63 c .        .     .        . 19 : apobch                                .
  64 c .        .     .        . 20 : apprpg                                .
  65 c .        .     .        . 21 : apvatt                                .
  66 c .        .     .        . 22 : apvane                                .
  67 c .        .     .        . 23 : antyas                                .
  68 c .        .     .        . 24 : aptyas                                .
  69 c .        .     .        . 25 : numero de la 1ere fonction associee   .
  70 c .        .     .        . 26 : numero de la 2nde fonction associee   .
  71 c . carchf . e   .nbpara* . caracteristiques caracteres des fonctions :.
  72 c .        .     .  nnfopa.  1 : nom de la fonction                    .
  73 c .        .     .        .  2 : nom de la fonction n associee         .
  74 c .        .     .        .  3 : nom de la fonction p associee         .
  75 c .        .     .        .  4 : obpcan                                .
  76 c .        .     .        .  5 : obpcap                                .
  77 c .        .     .        .  6 : obprof                                .
  78 c .        .     .        .  7 : oblopg                                .
  79 c .        .     .        .  8 : si aux points de Gauss, nom de la     .
  80 c .        .     .        .      fonction n ELNO correspondante        .
  81 c .        .     .        .  9 : si aux points de Gauss, nom de la     .
  82 c .        .     .        .      fonction p ELNO correspondante        .
  83 c . nrfonc . e   .    1   . numero de la fonction a examiner           .
  84 c . typfon .   s .   1    . 0, si ancienne isolee, 1, si ancienne      .
  85 c .        .     .        . associee a une  autre fonction, -1, si     .
  86 c .        .     .        . nouvelle                                   .
  87 c . typcha .   s .   1    . edin64/edfl64 selon entier/reel            .
  88 c . typgeo .   s .   1    . type geometrique au sens MED               .
  89 c . ngauss .   s .   1    . nombre de points de Gauss                  .
  90 c . nbenmx .   s .   1    . nombre d'entites maximum                   .
  91 c . nbvapr .   s .   1    . nombre de valeurs du profil                .
  92 c .        .     .        . -1, si pas de profil                       .
  93 c . nbtyas .   s .   1    . 0, si aucun autre type geometrique n'est   .
  94 c .        .     .        . associe dans une autre fonction            .
  95 c .        .     .        . n, produit des types associes              .
  96 c . nbtafo .   s .   1    . nombre de tableaux de la fonction          .
  97 c . anvale .   s .   1    . adresse du tableau de valeurs entieres     .
  98 c . anvalr .   s .   1    . adresse du tableau de valeurs reelles      .
  99 c . anobch .   s .   1    . adresse des noms des objets 'Champ'        .
 100 c . anprpg .   s .   1    . adresse des noms des objets 'Profil' et    .
 101 c .        .     .        . 'LocaPG' eventuellement associes           .
 102 c . anlipr .   s .   1    . adresse du tableau de travail              .
 103 c . npenmx .   s .   1    . nombre d'entites maximum                   .
 104 c . npvapr .   s .   1    . nombre de valeurs du profil                .
 105 c .        .     .        . -1, si pas de profil                       .
 106 c . apvale .   s .   1    . adresse du tableau de valeurs entieres     .
 107 c . apvalr .   s .   1    . adresse du tableau de valeurs reelles      .
 108 c . apobch .   s .   1    . adresse des noms des objets 'Champ'        .
 109 c . apprpg .   s .   1    . adresse des noms des objets 'Profil' et    .
 110 c .        .     .        . 'LocaPG' eventuellement associes           .
 111 c . apvatt .   s .   1    . adresse du tableau de travail              .
 112 c . nofonc .   s . char*8 . nom de la fonction                         .
 113 c . obpcan .   s . char*8 . objet du profil en entree                  .
 114 c . obpcap .   s . char*8 . objet du profil en sortie                  .
 115 c . obprof .   s . char*8 . objet du profil global                     .
 116 c . oblopg .   s . char*8 . objet de la localisation des pts de Gauss  .
 117 c . adpcan .   s .   1    . adresse du profil en entree                .
 118 c . adpcap .   s .   1    . adresse du profil en sortie                .
 119 c . nrfon2 .   s .   1   . numero de la 1ere fonction associee         .
 120 c . nrfon3 .   s .   1   . numero de la 2nde fonction associee         .
 121 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 122 c . langue . e   .    1   . langue des messages                        .
 123 c .        .     .        . 1 : francais, 2 : anglais                  .
 124 c . codret . es  .    1   . code de retour des modules                 .
 125 c .        .     .        . 0 : pas de probleme                        .
 126 c .        .     .        . 1 : probleme                               .
 127 c ______________________________________________________________________
 128 c
 129 c====
 130 c 0. declarations et dimensionnement
 131 c====
 132 c
 133 c 0.1. ==> generalites
 134 c
 135       implicit none
 136       save
 137 c
 138       character*6 nompro
 139       parameter ( nompro = 'PCFOR2' )
 140 c
 141 #include "nblang.h"
 142 #include "consts.h"
 143 #include "meddc0.h"
 144 c
 145 c 0.2. ==> communs
 146 c
 147 #include "envex1.h"
 148 c
 149 c 0.3. ==> arguments
 150 c
 151       integer nbpara
 152       integer carenf(nbpara,*)
 153 c
 154       integer nrfonc
 155       integer typfon, typcha, typgeo, nbtyas
 156       integer ngauss, nnenmx, nnvapr, carsup, nbtafo
 157       integer anvale, anvalr, anprpg, anobch, anlipr
 158       integer npenmx, npvapr
 159       integer apvale, apvalr, apprpg, apobch, apvatt
 160       integer apvane, aptyas
 161       integer adpcan, adpcap
 162       integer nrfon2, nrfon3
 163 c
 164       character*8 carchf(nbpara,*)
 165       character*8 nofonc, obpcan, obpcap, obprof
 166       character*8 oblopg
 167 c
 168       integer ulsort, langue, codret
 169 c
 170 c 0.4. ==> variables locales
 171 c
 172       integer iaux
 173       integer codre1, codre2
 174       integer codre0
 175 c
 176       integer nbmess
 177       parameter ( nbmess = 10 )
 178       character*80 texte(nblang,nbmess)
 179 c
 180 c 0.5. ==> initialisations
 181 c ______________________________________________________________________
 182 c
 183 c====
 184 c 1. initialisations
 185 c====
 186 c
 187 c 1.1. ==> messages
 188 c
 189 #include "impr01.h"
 190 c
 191 #ifdef _DEBUG_HOMARD_
 192       write (ulsort,texte(langue,1)) 'Entree', nompro
 193       call dmflsh (iaux)
 194 #endif
 195 c
 196       texte(1,6) = '(''.... profil '',a,'' : '',a)'
 197 c
 198       texte(2,6) = '(''.... profile '',a,'' : '',a)'
 199 c
 200 #include "pcimp1.h"
 201 #include "impr03.h"
 202 c
 203 #ifdef _DEBUG_HOMARD_
 204       write (ulsort,texte(langue,4)) nrfonc
 205 cgn      write(ulsort,90002) 'carenf  ',(carenf(iaux,nrfonc),iaux= 1,10)
 206 cgn      write(ulsort,90002) 'carenf  ',(carenf(iaux,nrfonc),iaux=11,20)
 207 cgn      write(ulsort,90002) 'carenf  ',
 208 cgn     >                    (carenf(iaux,nrfonc),iaux=21,nbpara)
 209 cgn      write(ulsort,90003) 'carchf  ',(carchf(iaux,nrfonc),iaux= 1,9)
 210 #endif
 211 c
 212 c====
 213 c 2. le nom de l'objet fonction
 214 c====
 215 c
 216       if ( codret.eq.0 ) then
 217 c
 218       nofonc = carchf( 1,nrfonc)
 219 c
 220       endif
 221 c
 222 c====
 223 c 3. les entiers
 224 c====
 225 c
 226       if ( codret.eq.0 ) then
 227 c
 228       typfon = carenf( 1,nrfonc)
 229       typcha = carenf( 2,nrfonc)
 230       typgeo = carenf( 3,nrfonc)
 231       nbtyas = carenf( 4,nrfonc)
 232       ngauss = carenf( 5,nrfonc)
 233       nnenmx = carenf( 6,nrfonc)
 234       nnvapr = carenf( 7,nrfonc)
 235       carsup = carenf( 8,nrfonc)
 236       nbtafo = carenf( 9,nrfonc)
 237 c
 238       anvale = carenf(10,nrfonc)
 239       anvalr = carenf(11,nrfonc)
 240       anobch = carenf(12,nrfonc)
 241       anprpg = carenf(13,nrfonc)
 242       anlipr = carenf(14,nrfonc)
 243 c
 244       npenmx = carenf(15,nrfonc)
 245       npvapr = carenf(16,nrfonc)
 246 c
 247       apvale = carenf(17,nrfonc)
 248       apvalr = carenf(18,nrfonc)
 249       apobch = carenf(19,nrfonc)
 250       apprpg = carenf(20,nrfonc)
 251       apvatt = carenf(21,nrfonc)
 252 c
 253       apvane = carenf(22,nrfonc)
 254 c
 255       aptyas = carenf(24,nrfonc)
 256 c
 257       nrfon2 = carenf(25,nrfonc)
 258       nrfon3 = carenf(26,nrfonc)
 259 c
 260       endif
 261 c
 262 #ifdef _DEBUG_HOMARD_
 263       write (ulsort,*) ' '
 264       write (ulsort,90002) 'typfon', typfon
 265       write (ulsort,90002) 'typcha', typcha
 266       write (ulsort,90002) 'typgeo', typgeo
 267       write (ulsort,90002) 'nbtyas', nbtyas
 268       write (ulsort,90002) 'ngauss', ngauss
 269       write (ulsort,90002) 'nnenmx', nnenmx
 270       write (ulsort,90002) 'nnvapr', nnvapr
 271       write (ulsort,90002) 'nbtafo', nbtafo
 272 c
 273       write (ulsort,90002) 'npenmx', npenmx
 274       write (ulsort,90002) 'npvapr', npvapr
 275 c
 276       write (ulsort,90002) 'anvale', anvale
 277       write (ulsort,90002) 'anvalr', anvalr
 278       write (ulsort,90002) 'anobch', anobch
 279       write (ulsort,90002) 'anprpg', anprpg
 280       write (ulsort,90002) 'anlipr', anlipr
 281 c
 282       write (ulsort,90002) 'apvale', apvale
 283       write (ulsort,90002) 'apvalr', apvalr
 284       write (ulsort,90002) 'apobch', apobch
 285       write (ulsort,90002) 'apprpg', apprpg
 286       write (ulsort,90002) 'apvatt', apvatt
 287 c
 288       write (ulsort,90002) 'apvane', apvane
 289 c
 290       write (ulsort,90002) 'aptyas', aptyas
 291 c
 292       write (ulsort,90002) 'nrfon2', nrfon2
 293       write (ulsort,90002) 'nrfon3', nrfon3
 294 #endif
 295 c
 296 c====
 297 c 4. les noms des profils
 298 c====
 299 c
 300       if ( codret.eq.0 ) then
 301 c
 302       obpcan = carchf( 4,nrfonc)
 303       obpcap = carchf( 5,nrfonc)
 304       obprof = carchf( 6,nrfonc)
 305 c
 306 #ifdef _DEBUG_HOMARD_
 307       write (ulsort,*) ' '
 308       write (ulsort,texte(langue,6)) 'n', obpcan
 309       call gmprsx (nompro,obpcan)
 310       write (ulsort,texte(langue,6)) 'p', obpcap
 311       call gmprsx (nompro,obpcap)
 312       write (ulsort,texte(langue,6)) 'g', obprof
 313 #endif
 314 c
 315       if ( typfon.ge.0 ) then
 316         call gmadoj ( obpcan, adpcan, iaux, codre1 )
 317       else
 318         codre1 = 0
 319       endif
 320       call gmadoj ( obpcap, adpcap, iaux, codre2 )
 321 c
 322       codre0 = min ( codre1, codre2 )
 323       codret = max ( abs(codre0), codret,
 324      >               codre1, codre2 )
 325 c
 326       endif
 327 c
 328 c====
 329 c 5. les localisations de points de Gauss
 330 c====
 331 c
 332       if ( codret.eq.0 ) then
 333 c
 334       oblopg = carchf( 7,nrfonc)
 335 c
 336 #ifdef _DEBUG_HOMARD_
 337       if ( oblopg.ne.blan08 ) then
 338       write (ulsort,*) ' '
 339       write (ulsort,*) 'Objet localisations des points de Gauss'
 340       call gmprsx (nompro,oblopg)
 341       endif
 342 #endif
 343 c
 344       endif
 345 c
 346 c====
 347 c 6. la fin
 348 c====
 349 c
 350       if ( codret.ne.0 ) then
 351 c
 352 #include "envex2.h"
 353 c
 354       write (ulsort,texte(langue,1)) 'Sortie', nompro
 355       write (ulsort,texte(langue,2)) codret
 356 c
 357       endif
 358 c
 359 #ifdef _DEBUG_HOMARD_
 360       write (ulsort,texte(langue,1)) 'Sortie', nompro
 361       call dmflsh (iaux)
 362 #endif
 363 c
 364       end