src/tool/AP_Conversion/pcfor1.F

   1       subroutine pcfor1 ( option,
   2      >                    nofonc, nrfonc,
   3      >                    nbpara, carenf, carchf,
   4      >                    nopafo, nbfopa,
   5      >                    nbtrav, litrav,
   6      >                    typfon, typcha, typgeo, nbtyas,
   7      >                    ngauss, nbenmx, nbvapr,
   8      >                    carsup, nbtafo, typint,
   9      >                    lgtbix, tbiaux,
  10      >                    advale, advalr, adobch, adprpg, adtyas,
  11      >                    advatt,
  12      >                    ulsort, langue, codret )
  13 c ______________________________________________________________________
  14 c
  15 c                             H O M A R D
  16 c
  17 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  18 c
  19 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  20 c aupres des huissiers de justice Simart et Lavoir a Clamart
  21 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  22 c aupres des huissiers de justice
  23 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  24 c
  25 c    HOMARD est une marque deposee d'Electricite de France
  26 c
  27 c Copyright EDF 1996
  28 c Copyright EDF 1998
  29 c Copyright EDF 2002
  30 c Copyright EDF 2020
  31 c ______________________________________________________________________
  32 c
  33 c    aPres adaptation - Fonctions - Recuperation - phase 1
  34 c     -                 --          -                    -
  35 c ______________________________________________________________________
  36 c .        .     .        .                                            .
  37 c .  nom   . e/s . taille .           description                      .
  38 c .____________________________________________________________________.
  39 c . option . e   .    1   . option du traitement                       .
  40 c .        .     .        . -1 : Pas de changement dans le maillage    .
  41 c .        .     .        .  0 : Adaptation complete                   .
  42 c .        .     .        .  1 : Modification de degre                 .
  43 c . nofonc . e   . char8  . nom de l'objet fonction similaire          .
  44 c . nrfonc . e   .   1    . numero de la fonction dans le tableau      .
  45 c . nbpara . e   .   1    . nombre de parametres a enregistrer par fonc.
  46 c . carenf .   s .nbpara* . caracteristiques entieres des fonctions :  .
  47 c .        .     .  nnfopa.  1 : 0, pour une fonction ancienne isolee  .
  48 c .        .     .        .      1, pour une ancienne associee a une   .
  49 c .        .     .        .         autre fonction                     .
  50 c .        .     .        .      -1, pour une nouvelle fonction        .
  51 c .        .     .        .  2 : typcha                                .
  52 c .        .     .        .  3 : typgeo                                .
  53 c .        .     .        .  4 : nbtyas                                .
  54 c .        .     .        .  5 : ngauss                                .
  55 c .        .     .        .  6 : nnenmx                                .
  56 c .        .     .        .  7 : nnvapr                                .
  57 c .        .     .        .  8 : nbtafo                                .
  58 c .        .     .        .  9 : libre                                 .
  59 c .        .     .        . 10 : anvale                                .
  60 c .        .     .        . 11 : anvalr                                .
  61 c .        .     .        . 12 : anobch                                .
  62 c .        .     .        . 13 : anprpg                                .
  63 c .        .     .        . 14 : anlipr                                .
  64 c .        .     .        . 15 : npenmx                                .
  65 c .        .     .        . 16 : npvapr                                .
  66 c .        .     .        . 17 : apvale                                .
  67 c .        .     .        . 18 : apvalr                                .
  68 c .        .     .        . 19 : apobch                                .
  69 c .        .     .        . 20 : apprpg                                .
  70 c .        .     .        . 21 : apvatt                                .
  71 c .        .     .        . 22 : apvane                                .
  72 c .        .     .        . 23 : antyas                                .
  73 c .        .     .        . 24 : aptyas                                .
  74 c .        .     .        . 25 : numero de la 1ere fonction associee   .
  75 c .        .     .        . 26 : numero de la 2nde fonction associee   .
  76 c . carchf . es  .nbpara* . caracteristiques caracteres des fonctions :.
  77 c .        .     .  nnfopa.  1 : nom de la fonction                    .
  78 c .        .     .        .  2 : nom de la fonction n associee         .
  79 c .        .     .        .  3 : nom de la fonction p associee         .
  80 c .        .     .        .  4 : obpcan                                .
  81 c .        .     .        .  5 : obpcap                                .
  82 c .        .     .        .  6 : obprof                                .
  83 c .        .     .        .  7 : oblopg                                .
  84 c .        .     .        .  8 : si aux points de Gauss, nom de la     .
  85 c .        .     .        .      fonction n ELNO correspondante        .
  86 c .        .     .        .  9 : si aux points de Gauss, nom de la     .
  87 c .        .     .        .      fonction p ELNO correspondante        .
  88 c . nopafo . es  .    1   . nom du paquet de fonctions a enrichir      .
  89 c . nbfopa .  s  .   1    . nombre de fonctions du paquet a enrichir   .
  90 c . nbtrav . es  .   1    . nombre de tableaux de travail crees        .
  91 c . litrav . es  .   *    . liste des noms de tableaux de travail crees.
  92 c . typcha . e   .   1    . edin64/edfl64 selon entier/reel            .
  93 c . typgeo . e   .   1    . type geometrique au sens MED               .
  94 c . ngauss . e   .   1    . nombre de points de Gauss                  .
  95 c . nbenmx . e   .   1    . nombre d'entites maximum                   .
  96 c . nbvapr . e   .   1    . nombre de valeurs du profil                .
  97 c .        .     .        . -1, si pas de profil                       .
  98 c . nbtyas . e   .   1    . nombre de types de support associes        .
  99 c . carsup . e   .   1    . caracteristiques du support                .
 100 c .        .     .        . 1, si aux noeuds par element               .
 101 c .        .     .        . 2, si aux points de Gauss, associe avec    .
 102 c .        .     .        .    n champ aux noeuds par elements         .
 103 c .        .     .        . 3 si aux points de Gauss autonome          .
 104 c .        .     .        . 0, sinon                                   .
 105 c . nbtafo . e   .   1    . nombre de tableaux de la fonction          .
 106 c . typint . e   .        . type interpolation                         .
 107 c .        .     .        . 0, si automatique                          .
 108 c .        .     .        . 1 si degre 1, 2 si degre 2,                .
 109 c .        .     .        . 3 si iso-P2                                .
 110 c . lgtbix . e   .   1    . nouveau nombre de types de support associes.
 111 c . tbiaux . e   . lgtbix . nouveaux types de support associes         .
 112 c . advale .   s .   1    . adresse du tableau de valeurs entieres     .
 113 c . advalr .   s .   1    . adresse du tableau de valeurs reelles      .
 114 c . adobch .   s .   1    . adresse des noms des objets 'Champ'        .
 115 c . adprpg .   s .   1    . adresse des noms des objets 'Profil' et    .
 116 c .        .     .        . 'LocaPG' eventuellement associes           .
 117 c . adtyas .   s .   1    . adresse des types associes                 .
 118 c . advatt .   s .   1    . adresse du tableau de travail              .
 119 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 120 c . langue . e   .    1   . langue des messages                        .
 121 c .        .     .        . 1 : francais, 2 : anglais                  .
 122 c . codret . es  .    1   . code de retour des modules                 .
 123 c .        .     .        . 0 : pas de probleme                        .
 124 c .        .     .        . 1 : probleme                               .
 125 c ______________________________________________________________________
 126 c
 127 c====
 128 c 0. declarations et dimensionnement
 129 c====
 130 c
 131 c 0.1. ==> generalites
 132 c
 133       implicit none
 134       save
 135 c
 136       character*6 nompro
 137       parameter ( nompro = 'PCFOR1' )
 138 c
 139 #include "nblang.h"
 140 #include "consts.h"
 141 #include "meddc0.h"
 142 c
 143 c 0.2. ==> communs
 144 c
 145 #include "envex1.h"
 146 c
 147 #include "nombsr.h"
 148 #include "gmenti.h"
 149 #include "rftmed.h"
 150 c
 151 c 0.3. ==> arguments
 152 c
 153       integer option
 154       integer nbpara
 155       integer carenf(nbpara,*)
 156 c
 157       integer nrfonc
 158       integer typfon, typcha, typgeo, nbtyas
 159       integer ngauss, nbenmx, nbvapr
 160       integer carsup, nbtafo, typint
 161       integer nbfopa, nbtrav
 162       integer advale, advalr, adprpg, adtyas
 163       integer adobch, advatt
 164       integer lgtbix, tbiaux(lgtbix)
 165 c
 166       character*8 nofonc
 167       character*8 carchf(nbpara,*)
 168       character*8 litrav(*)
 169       character*8 nopafo
 170 c
 171       integer ulsort, langue, codret
 172 c
 173 c 0.4. ==> variables locales
 174 c
 175       integer iaux, jaux, kaux, laux, maux
 176       integer adobfo
 177 c
 178       integer ngausa, nnenma, nnvapa, nbtyaa
 179       integer carsua, nbtafa, typina
 180       integer apvane, anvala, anobca, anprpa, antyaa
 181       integer codre1, codre2
 182       integer codre0
 183 c
 184       character*8 nofon2
 185       character*8 saux08
 186       character*8 tbsaux(1)
 187 c
 188       integer nbmess
 189       parameter ( nbmess = 10 )
 190       character*80 texte(nblang,nbmess)
 191 c
 192 c 0.5. ==> initialisations
 193 c ______________________________________________________________________
 194 c
 195 c====
 196 c 1. initialisations
 197 c====
 198 c
 199 c 1.1. ==> messages
 200 c
 201 #include "impr01.h"
 202 #include "impr03.h"
 203 c
 204 #ifdef _DEBUG_HOMARD_
 205       write (ulsort,texte(langue,1)) 'Entree', nompro
 206       call dmflsh (iaux)
 207 #endif
 208 c
 209       texte(1,4) = '(''Fonction de depart : '',a)'
 210       texte(1,5) = '(''Fonction creee : '',a)'
 211       texte(1,6) = '(''En retour de '',a,'', codret ='',i13)'
 212 c
 213       texte(2,4) = '(''Initial function : '',a)'
 214       texte(2,5) = '(''Created function : '',a)'
 215       texte(2,6) = '(''Back from '',a,'', codret ='',i13)'
 216 c
 217       codret = 0
 218 c
 219 #ifdef _DEBUG_HOMARD_
 220       write (ulsort,texte(langue,4)) nofonc
 221       write (ulsort,90002) 'option', option
 222 #endif
 223 cgn      print *, 'DEBUT DE ',nompro, ' pour la fonction numero ',nrfonc
 224 cgn      print 1788,(carenf(iaux,nrfonc),iaux=1,nbpara)
 225 cgn      print 1789,(carchf(iaux,nrfonc),iaux=1,9)
 226 c
 227 c====
 228 c 2. modification eventuelle des caracteristiques
 229 c====
 230 c
 231       if ( codret.eq.0 ) then
 232 c
 233       if ( option.eq.1 ) then
 234 c
 235 cgn      write (ulsort,90002) 'typgeo initial', typgeo
 236         typgeo = medt12(typgeo)
 237 cgn      write (ulsort,90002) 'ngauss typgeo', typgeo
 238 c
 239         if ( carsup.eq.1 ) then
 240 cgn      write (ulsort,90002) 'ngauss initial', ngauss
 241           ngauss = mednnm(typgeo)
 242 cgn      write (ulsort,90002) 'nouveau ngauss', ngauss
 243         endif
 244 c
 245       endif
 246 c
 247 #ifdef _DEBUG_HOMARD_
 248       write (ulsort,90002) 'typgeo', typgeo
 249       write (ulsort,90002) 'ngauss', ngauss
 250       write (ulsort,90002) 'nbenmx', nbenmx
 251       write (ulsort,90002) 'nbvapr', nbvapr
 252       write (ulsort,90002) 'nbtyas', nbtyas
 253       write (ulsort,90002) 'carsup', carsup
 254       write (ulsort,90002) 'nbtafo', nbtafo
 255       write (ulsort,90002) 'typint', typint
 256       write (ulsort,90002) 'lgtbix', lgtbix
 257       if ( lgtbix.gt.0 ) then
 258         write (ulsort,90002) '==> ', (tbiaux(iaux),iaux=1,lgtbix)
 259       endif
 260 #endif
 261 c
 262       endif
 263 c
 264 c====
 265 c 3. allocation de la fonction
 266 c====
 267 c
 268       if ( codret.eq.0 ) then
 269 c
 270 #ifdef _DEBUG_HOMARD_
 271       write (ulsort,texte(langue,3)) 'UTALFO', nompro
 272 #endif
 273       call utalfo ( nofon2, typcha,
 274      >              typgeo, ngauss, nbenmx, nbvapr, nbtyas,
 275      >              carsup, nbtafo, typint,
 276      >              advale, advalr, adobch, adprpg, adtyas,
 277      >              ulsort, langue, codret )
 278 c
 279 #ifdef _DEBUG_HOMARD_
 280       if ( codret.ne.0 ) then
 281         write (ulsort,texte(langue,6)) 'utalfo', codret
 282       endif
 283       write (ulsort,texte(langue,5)) nofon2
 284       call gmprsx (nompro, nofon2 )
 285 #endif
 286 c
 287       endif
 288 c
 289       if ( codret.eq.0 ) then
 290 c
 291       carenf( 1,nrfonc) = typfon
 292       carenf( 2,nrfonc) = typcha
 293       carenf( 3,nrfonc) = typgeo
 294       carenf( 4,nrfonc) = nbtyas
 295       carenf( 5,nrfonc) = ngauss
 296       carenf( 6,nrfonc) = 0
 297       carenf( 7,nrfonc) = nbvapr
 298       carenf( 8,nrfonc) = carsup
 299       carenf( 9,nrfonc) = nbtafo
 300       carenf(15,nrfonc) = nbenmx
 301       carenf(16,nrfonc) = nbvapr
 302       carenf(17,nrfonc) = advale
 303       carenf(18,nrfonc) = advalr
 304       carenf(19,nrfonc) = adobch
 305       carenf(20,nrfonc) = adprpg
 306       carenf(23,nrfonc) = adtyas
 307 c
 308       carchf( 1,nrfonc) = nofon2
 309 c
 310       endif
 311 c
 312 c====
 313 c 4. caracteristiques des supports associes
 314 c====
 315 #ifdef _DEBUG_HOMARD_
 316       write (ulsort,*) '4. supports associes ; codret = ', codret
 317 #endif
 318 c
 319 c 4.1. ==> S'il n'y a pas d'ajout de fonction pour la conformite,
 320 c          lgtbix vaut nbtyas.
 321 c          Donc si on avait deja des supports (nbtyas>0), il faut
 322 c          recopier le tableau.
 323 c
 324       if ( lgtbix.eq.nbtyas ) then
 325 c
 326         if ( nbtyas.gt.0 ) then
 327 c
 328           if ( codret.eq.0 ) then
 329 c
 330 #ifdef _DEBUG_HOMARD_
 331       write (ulsort,*) 'Copie de', nofonc//'.TypeSuAs',
 332      >                 ' vers', nofon2//'.TypeSuAs'
 333 #endif
 334           call gmcpgp ( nofonc//'.TypeSuAs',
 335      >                  nofon2//'.TypeSuAs', codret )
 336 c
 337           endif
 338 c
 339         endif
 340 c
 341 c 4.2. ==> S'il y a de nouveau support, lgtbix est different de nbtyas.
 342 c          Il faut creer la liste des supports.
 343 c
 344       else
 345 c
 346         if ( lgtbix.gt.0 ) then
 347 c
 348 c 4.2.1. ==> On commence par detruire le tableau s'il existait
 349 c
 350           if ( codret.eq.0 ) then
 351           if ( nbtyas.gt.0 ) then
 352 #ifdef _DEBUG_HOMARD_
 353       write (ulsort,*) 'Destruction de', nofon2//'.TypeSuAs'
 354 #endif
 355             call gmlboj( nofon2//'.TypeSuAs', codret )
 356           endif
 357           endif
 358 c
 359 c 4.2.2. ==> Allocation du tableau et mise a jour de l'attribut
 360 c
 361           if ( codret.eq.0 ) then
 362 #ifdef _DEBUG_HOMARD_
 363       write (ulsort,*) 'Allocation de', nofon2//'.TypeSuAs'
 364 #endif
 365           iaux = lgtbix - 1
 366           call gmaloj ( nofon2//'.TypeSuAs', ' ',
 367      >                  iaux, adtyas, codre1 )
 368           call gmecat ( nofon2, 5, iaux, codre2 )
 369 c
 370           codre0 = min ( codre1, codre2 )
 371           codret = max ( abs(codre0), codret,
 372      >                   codre1, codre2 )
 373           endif
 374 c
 375 c 4.2.3. ==> Valeurs
 376 c
 377           if ( codret.eq.0 ) then
 378 c
 379           carenf( 4,nrfonc) = lgtbix - 1
 380           carenf(23,nrfonc) = adtyas
 381 c
 382           jaux = adtyas - 1
 383           do 423 , iaux = 1 , lgtbix
 384             if ( tbiaux(iaux).ne.typgeo ) then
 385               jaux = jaux + 1
 386               imem(jaux) = tbiaux(iaux)
 387             endif
 388   423     continue
 389 c
 390           endif
 391 c
 392         endif
 393 c
 394       endif
 395 c
 396 #ifdef _DEBUG_HOMARD_
 397       call gmprsx ( nompro, nofon2 )
 398       call gmprsx ( nompro, nofon2//'.TypeSuAs' )
 399 #endif
 400 c
 401 c====
 402 c 5. copie des caracteristiques du champ
 403 c====
 404 c
 405 #ifdef _DEBUG_HOMARD_
 406       write (ulsort,*) '5. champ ; codret = ', codret
 407 #endif
 408 c
 409       if ( codret.eq.0 ) then
 410 c
 411       call gmcpgp ( nofonc//'.InfoCham',
 412      >              nofon2//'.InfoCham', codret )
 413 c
 414       endif
 415 c
 416 c====
 417 c 6. dans le cas de support element, creation d'un tableau de
 418 c    travail pour gerer la renumerotation
 419 c====
 420 c
 421 #ifdef _DEBUG_HOMARD_
 422       write (ulsort,*) '6. support element ; codret = ', codret
 423 #endif
 424 c
 425       if ( typgeo.ne.0 ) then
 426 c
 427 c 6.1. ==> Taille
 428 c
 429         if ( codret.eq.0 ) then
 430 c
 431         iaux = nbtafo * rseutc
 432 c
 433         if ( ngauss.ne.ednopg ) then
 434           iaux = ngauss*iaux
 435         endif
 436 c
 437         endif
 438 c
 439 c 6.2. ==> Allocation
 440 c
 441         if ( codret.eq.0 ) then
 442 cgn      write (ulsort,90002) 'allocation a la taille', iaux
 443 c
 444         call gmalot ( saux08, 'reel    ', iaux, advatt, codret )
 445 cgn      write (ulsort,90003) 'allocation de', saux08
 446 c
 447         endif
 448 c
 449 c 6.3. ==> Archivage
 450 c
 451         if ( codret.eq.0 ) then
 452 c
 453         nbtrav = nbtrav + 1
 454         litrav(nbtrav) = saux08
 455 cgn        print *,nompro,' 2.3 nbtrav = ', nbtrav
 456 cgn        print *,'litrav(',nbtrav,') = ',saux08
 457 cgn        carenf( 5,nrfonc) = ngauss
 458         carenf(21,nrfonc) = advatt
 459 c
 460         endif
 461 c
 462       endif
 463 c
 464 c====
 465 c 7. dans le cas d'un champ aux points de Gauss avec un champ aux
 466 c    noeuds par elements associe, reperage de la fonction associee
 467 c====
 468 c
 469 #ifdef _DEBUG_HOMARD_
 470       write (ulsort,*) '7. support Gauss ; codret = ', codret
 471 #endif
 472 c
 473       if ( carsup.eq.2 ) then
 474 c
 475         if ( codret.eq.0 ) then
 476 c
 477         saux08 = carchf(9,nrfonc)
 478 cgn        call gmprsx (nompro,saux08)
 479 cgn        call gmprsx (nompro,saux08//'.ValeursR')
 480 c
 481 #ifdef _DEBUG_HOMARD_
 482         write (ulsort,texte(langue,3)) 'UTCAFO', nompro
 483 #endif
 484         call utcafo ( saux08,
 485      >                typcha,
 486      >                typgeo, ngausa, nnenma, nnvapa, nbtyaa,
 487      >                carsua, nbtafa, typina,
 488      >                anvala, apvane, anobca, anprpa, antyaa,
 489      >                ulsort, langue, codret )
 490 c
 491         carenf(22,nrfonc) = apvane
 492 cgn        print *,'apvane = ',apvane
 493 c
 494         endif
 495 c
 496       endif
 497 c
 498 c====
 499 c 8. ajout de la fonction au paquet de sortie
 500 c====
 501 c
 502 #ifdef _DEBUG_HOMARD_
 503       write (ulsort,*) '8. ajout ; codret = ', codret
 504 #endif
 505 c
 506       if ( codret.eq.0 ) then
 507 c
 508 #ifdef _DEBUG_HOMARD_
 509       write (ulsort,texte(langue,3)) 'UTMOPF', nompro
 510 #endif
 511       iaux = 1
 512       call utmopf ( nopafo, iaux,
 513      >              iaux, tbsaux, tbiaux,
 514      >              nofon2,
 515      >              nbfopa, jaux, kaux, laux, maux,
 516      >              adobfo,
 517      >              ulsort, langue, codret )
 518 c
 519       endif
 520 c
 521 #ifdef _DEBUG_HOMARD_
 522       call gmprsx (nompro, nopafo )
 523       call gmprsx (nompro, nopafo//'.Fonction' )
 524       call gmprsx (nompro, nofon2//'.ValeursR' )
 525       call gmprsx (nompro, nofon2//'.InfoPrPG' )
 526 #endif
 527 c
 528 c====
 529 c 9. la fin
 530 c====
 531 c
 532 cgn      print *, 'FIN DE ',nompro, ' pour la fonction numero ',nrfonc
 533 cgn      print 1788,(carenf(iaux,nrfonc),iaux=1,nbpara)
 534 cgn 1788  format(10I8)
 535 cgn      print 1789,(carchf(iaux,nrfonc),iaux=1,9)
 536 cgn 1789  format(10(a8,1x))
 537 cgn      print *, ' '
 538 c
 539       if ( codret.ne.0 ) then
 540 c
 541 #include "envex2.h"
 542 c
 543       write (ulsort,texte(langue,1)) 'Sortie', nompro
 544       write (ulsort,texte(langue,2)) codret
 545 c
 546       endif
 547 c
 548 #ifdef _DEBUG_HOMARD_
 549       write (ulsort,texte(langue,1)) 'Sortie', nompro
 550       call dmflsh (iaux)
 551 #endif
 552 c
 553       end