--- /dev/null
+ subroutine pcfor1 ( option,
+ > nofonc, nrfonc,
+ > nbpara, carenf, carchf,
+ > nopafo, nbfopa,
+ > nbtrav, litrav,
+ > typfon, typcha, typgeo, nbtyas,
+ > ngauss, nbenmx, nbvapr,
+ > carsup, nbtafo, typint,
+ > lgtbix, tbiaux,
+ > advale, advalr, adobch, adprpg, adtyas,
+ > advatt,
+ > ulsort, langue, codret )
+c ______________________________________________________________________
+c
+c H O M A R D
+c
+c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
+c
+c Version originale enregistree le 18 juin 1996 sous le numero 96036
+c aupres des huissiers de justice Simart et Lavoir a Clamart
+c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
+c aupres des huissiers de justice
+c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
+c
+c HOMARD est une marque deposee d'Electricite de France
+c
+c Copyright EDF 1996
+c Copyright EDF 1998
+c Copyright EDF 2002
+c Copyright EDF 2020
+c ______________________________________________________________________
+c
+c aPres adaptation - Fonctions - Recuperation - phase 1
+c - -- - -
+c ______________________________________________________________________
+c . . . . .
+c . nom . e/s . taille . description .
+c .____________________________________________________________________.
+c . option . e . 1 . option du traitement .
+c . . . . -1 : Pas de changement dans le maillage .
+c . . . . 0 : Adaptation complete .
+c . . . . 1 : Modification de degre .
+c . nofonc . e . char8 . nom de l'objet fonction similaire .
+c . nrfonc . e . 1 . numero de la fonction dans le tableau .
+c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc.
+c . carenf . s .nbpara* . caracteristiques entieres des fonctions : .
+c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee .
+c . . . . 1, pour une ancienne associee a une .
+c . . . . autre fonction .
+c . . . . -1, pour une nouvelle fonction .
+c . . . . 2 : typcha .
+c . . . . 3 : typgeo .
+c . . . . 4 : nbtyas .
+c . . . . 5 : ngauss .
+c . . . . 6 : nnenmx .
+c . . . . 7 : nnvapr .
+c . . . . 8 : nbtafo .
+c . . . . 9 : libre .
+c . . . . 10 : anvale .
+c . . . . 11 : anvalr .
+c . . . . 12 : anobch .
+c . . . . 13 : anprpg .
+c . . . . 14 : anlipr .
+c . . . . 15 : npenmx .
+c . . . . 16 : npvapr .
+c . . . . 17 : apvale .
+c . . . . 18 : apvalr .
+c . . . . 19 : apobch .
+c . . . . 20 : apprpg .
+c . . . . 21 : apvatt .
+c . . . . 22 : apvane .
+c . . . . 23 : antyas .
+c . . . . 24 : aptyas .
+c . . . . 25 : numero de la 1ere fonction associee .
+c . . . . 26 : numero de la 2nde fonction associee .
+c . carchf . es .nbpara* . caracteristiques caracteres des fonctions :.
+c . . . nnfopa. 1 : nom de la fonction .
+c . . . . 2 : nom de la fonction n associee .
+c . . . . 3 : nom de la fonction p associee .
+c . . . . 4 : obpcan .
+c . . . . 5 : obpcap .
+c . . . . 6 : obprof .
+c . . . . 7 : oblopg .
+c . . . . 8 : si aux points de Gauss, nom de la .
+c . . . . fonction n ELNO correspondante .
+c . . . . 9 : si aux points de Gauss, nom de la .
+c . . . . fonction p ELNO correspondante .
+c . nopafo . es . 1 . nom du paquet de fonctions a enrichir .
+c . nbfopa . s . 1 . nombre de fonctions du paquet a enrichir .
+c . nbtrav . es . 1 . nombre de tableaux de travail crees .
+c . litrav . es . * . liste des noms de tableaux de travail crees.
+c . typcha . e . 1 . edin64/edfl64 selon entier/reel .
+c . typgeo . e . 1 . type geometrique au sens MED .
+c . ngauss . e . 1 . nombre de points de Gauss .
+c . nbenmx . e . 1 . nombre d'entites maximum .
+c . nbvapr . e . 1 . nombre de valeurs du profil .
+c . . . . -1, si pas de profil .
+c . nbtyas . e . 1 . nombre de types de support associes .
+c . carsup . e . 1 . caracteristiques du support .
+c . . . . 1, si aux noeuds par element .
+c . . . . 2, si aux points de Gauss, associe avec .
+c . . . . n champ aux noeuds par elements .
+c . . . . 3 si aux points de Gauss autonome .
+c . . . . 0, sinon .
+c . nbtafo . e . 1 . nombre de tableaux de la fonction .
+c . typint . e . . type interpolation .
+c . . . . 0, si automatique .
+c . . . . 1 si degre 1, 2 si degre 2, .
+c . . . . 3 si iso-P2 .
+c . lgtbix . e . 1 . nouveau nombre de types de support associes.
+c . tbiaux . e . lgtbix . nouveaux types de support associes .
+c . advale . s . 1 . adresse du tableau de valeurs entieres .
+c . advalr . s . 1 . adresse du tableau de valeurs reelles .
+c . adobch . s . 1 . adresse des noms des objets 'Champ' .
+c . adprpg . s . 1 . adresse des noms des objets 'Profil' et .
+c . . . . 'LocaPG' eventuellement associes .
+c . adtyas . s . 1 . adresse des types associes .
+c . advatt . s . 1 . adresse du tableau de travail .
+c . ulsort . e . 1 . numero d'unite logique de la liste standard.
+c . langue . e . 1 . langue des messages .
+c . . . . 1 : francais, 2 : anglais .
+c . codret . es . 1 . code de retour des modules .
+c . . . . 0 : pas de probleme .
+c . . . . 1 : probleme .
+c ______________________________________________________________________
+c
+c====
+c 0. declarations et dimensionnement
+c====
+c
+c 0.1. ==> generalites
+c
+ implicit none
+ save
+c
+ character*6 nompro
+ parameter ( nompro = 'PCFOR1' )
+c
+#include "nblang.h"
+#include "consts.h"
+#include "meddc0.h"
+c
+c 0.2. ==> communs
+c
+#include "envex1.h"
+c
+#include "nombsr.h"
+#include "gmenti.h"
+#include "rftmed.h"
+c
+c 0.3. ==> arguments
+c
+ integer option
+ integer nbpara
+ integer carenf(nbpara,*)
+c
+ integer nrfonc
+ integer typfon, typcha, typgeo, nbtyas
+ integer ngauss, nbenmx, nbvapr
+ integer carsup, nbtafo, typint
+ integer nbfopa, nbtrav
+ integer advale, advalr, adprpg, adtyas
+ integer adobch, advatt
+ integer lgtbix, tbiaux(lgtbix)
+c
+ character*8 nofonc
+ character*8 carchf(nbpara,*)
+ character*8 litrav(*)
+ character*8 nopafo
+c
+ integer ulsort, langue, codret
+c
+c 0.4. ==> variables locales
+c
+ integer iaux, jaux, kaux, laux, maux
+ integer adobfo
+c
+ integer ngausa, nnenma, nnvapa, nbtyaa
+ integer carsua, nbtafa, typina
+ integer apvane, anvala, anobca, anprpa, antyaa
+ integer codre1, codre2
+ integer codre0
+c
+ character*8 nofon2
+ character*8 saux08
+ character*8 tbsaux(1)
+c
+ integer nbmess
+ parameter ( nbmess = 10 )
+ character*80 texte(nblang,nbmess)
+c
+c 0.5. ==> initialisations
+c ______________________________________________________________________
+c
+c====
+c 1. initialisations
+c====
+c
+c 1.1. ==> messages
+c
+#include "impr01.h"
+#include "impr03.h"
+c
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,texte(langue,1)) 'Entree', nompro
+ call dmflsh (iaux)
+#endif
+c
+ texte(1,4) = '(''Fonction de depart : '',a)'
+ texte(1,5) = '(''Fonction creee : '',a)'
+ texte(1,6) = '(''En retour de '',a,'', codret ='',i13)'
+c
+ texte(2,4) = '(''Initial function : '',a)'
+ texte(2,5) = '(''Created function : '',a)'
+ texte(2,6) = '(''Back from '',a,'', codret ='',i13)'
+c
+ codret = 0
+c
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,texte(langue,4)) nofonc
+ write (ulsort,90002) 'option', option
+#endif
+cgn print *, 'DEBUT DE ',nompro, ' pour la fonction numero ',nrfonc
+cgn print 1788,(carenf(iaux,nrfonc),iaux=1,nbpara)
+cgn print 1789,(carchf(iaux,nrfonc),iaux=1,9)
+c
+c====
+c 2. modification eventuelle des caracteristiques
+c====
+c
+ if ( codret.eq.0 ) then
+c
+ if ( option.eq.1 ) then
+c
+cgn write (ulsort,90002) 'typgeo initial', typgeo
+ typgeo = medt12(typgeo)
+cgn write (ulsort,90002) 'ngauss typgeo', typgeo
+c
+ if ( carsup.eq.1 ) then
+cgn write (ulsort,90002) 'ngauss initial', ngauss
+ ngauss = mednnm(typgeo)
+cgn write (ulsort,90002) 'nouveau ngauss', ngauss
+ endif
+c
+ endif
+c
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,90002) 'typgeo', typgeo
+ write (ulsort,90002) 'ngauss', ngauss
+ write (ulsort,90002) 'nbenmx', nbenmx
+ write (ulsort,90002) 'nbvapr', nbvapr
+ write (ulsort,90002) 'nbtyas', nbtyas
+ write (ulsort,90002) 'carsup', carsup
+ write (ulsort,90002) 'nbtafo', nbtafo
+ write (ulsort,90002) 'typint', typint
+ write (ulsort,90002) 'lgtbix', lgtbix
+ if ( lgtbix.gt.0 ) then
+ write (ulsort,90002) '==> ', (tbiaux(iaux),iaux=1,lgtbix)
+ endif
+#endif
+c
+ endif
+c
+c====
+c 3. allocation de la fonction
+c====
+c
+ if ( codret.eq.0 ) then
+c
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,texte(langue,3)) 'UTALFO', nompro
+#endif
+ call utalfo ( nofon2, typcha,
+ > typgeo, ngauss, nbenmx, nbvapr, nbtyas,
+ > carsup, nbtafo, typint,
+ > advale, advalr, adobch, adprpg, adtyas,
+ > ulsort, langue, codret )
+c
+#ifdef _DEBUG_HOMARD_
+ if ( codret.ne.0 ) then
+ write (ulsort,texte(langue,6)) 'utalfo', codret
+ endif
+ write (ulsort,texte(langue,5)) nofon2
+ call gmprsx (nompro, nofon2 )
+#endif
+c
+ endif
+c
+ if ( codret.eq.0 ) then
+c
+ carenf( 1,nrfonc) = typfon
+ carenf( 2,nrfonc) = typcha
+ carenf( 3,nrfonc) = typgeo
+ carenf( 4,nrfonc) = nbtyas
+ carenf( 5,nrfonc) = ngauss
+ carenf( 6,nrfonc) = 0
+ carenf( 7,nrfonc) = nbvapr
+ carenf( 8,nrfonc) = carsup
+ carenf( 9,nrfonc) = nbtafo
+ carenf(15,nrfonc) = nbenmx
+ carenf(16,nrfonc) = nbvapr
+ carenf(17,nrfonc) = advale
+ carenf(18,nrfonc) = advalr
+ carenf(19,nrfonc) = adobch
+ carenf(20,nrfonc) = adprpg
+ carenf(23,nrfonc) = adtyas
+c
+ carchf( 1,nrfonc) = nofon2
+c
+ endif
+c
+c====
+c 4. caracteristiques des supports associes
+c====
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,*) '4. supports associes ; codret = ', codret
+#endif
+c
+c 4.1. ==> S'il n'y a pas d'ajout de fonction pour la conformite,
+c lgtbix vaut nbtyas.
+c Donc si on avait deja des supports (nbtyas>0), il faut
+c recopier le tableau.
+c
+ if ( lgtbix.eq.nbtyas ) then
+c
+ if ( nbtyas.gt.0 ) then
+c
+ if ( codret.eq.0 ) then
+c
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,*) 'Copie de', nofonc//'.TypeSuAs',
+ > ' vers', nofon2//'.TypeSuAs'
+#endif
+ call gmcpgp ( nofonc//'.TypeSuAs',
+ > nofon2//'.TypeSuAs', codret )
+c
+ endif
+c
+ endif
+c
+c 4.2. ==> S'il y a de nouveau support, lgtbix est different de nbtyas.
+c Il faut creer la liste des supports.
+c
+ else
+c
+ if ( lgtbix.gt.0 ) then
+c
+c 4.2.1. ==> On commence par detruire le tableau s'il existait
+c
+ if ( codret.eq.0 ) then
+ if ( nbtyas.gt.0 ) then
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,*) 'Destruction de', nofon2//'.TypeSuAs'
+#endif
+ call gmlboj( nofon2//'.TypeSuAs', codret )
+ endif
+ endif
+c
+c 4.2.2. ==> Allocation du tableau et mise a jour de l'attribut
+c
+ if ( codret.eq.0 ) then
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,*) 'Allocation de', nofon2//'.TypeSuAs'
+#endif
+ iaux = lgtbix - 1
+ call gmaloj ( nofon2//'.TypeSuAs', ' ',
+ > iaux, adtyas, codre1 )
+ call gmecat ( nofon2, 5, iaux, codre2 )
+c
+ codre0 = min ( codre1, codre2 )
+ codret = max ( abs(codre0), codret,
+ > codre1, codre2 )
+ endif
+c
+c 4.2.3. ==> Valeurs
+c
+ if ( codret.eq.0 ) then
+c
+ carenf( 4,nrfonc) = lgtbix - 1
+ carenf(23,nrfonc) = adtyas
+c
+ jaux = adtyas - 1
+ do 423 , iaux = 1 , lgtbix
+ if ( tbiaux(iaux).ne.typgeo ) then
+ jaux = jaux + 1
+ imem(jaux) = tbiaux(iaux)
+ endif
+ 423 continue
+c
+ endif
+c
+ endif
+c
+ endif
+c
+#ifdef _DEBUG_HOMARD_
+ call gmprsx ( nompro, nofon2 )
+ call gmprsx ( nompro, nofon2//'.TypeSuAs' )
+#endif
+c
+c====
+c 5. copie des caracteristiques du champ
+c====
+c
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,*) '5. champ ; codret = ', codret
+#endif
+c
+ if ( codret.eq.0 ) then
+c
+ call gmcpgp ( nofonc//'.InfoCham',
+ > nofon2//'.InfoCham', codret )
+c
+ endif
+c
+c====
+c 6. dans le cas de support element, creation d'un tableau de
+c travail pour gerer la renumerotation
+c====
+c
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,*) '6. support element ; codret = ', codret
+#endif
+c
+ if ( typgeo.ne.0 ) then
+c
+c 6.1. ==> Taille
+c
+ if ( codret.eq.0 ) then
+c
+ iaux = nbtafo * rseutc
+c
+ if ( ngauss.ne.ednopg ) then
+ iaux = ngauss*iaux
+ endif
+c
+ endif
+c
+c 6.2. ==> Allocation
+c
+ if ( codret.eq.0 ) then
+cgn write (ulsort,90002) 'allocation a la taille', iaux
+c
+ call gmalot ( saux08, 'reel ', iaux, advatt, codret )
+cgn write (ulsort,90003) 'allocation de', saux08
+c
+ endif
+c
+c 6.3. ==> Archivage
+c
+ if ( codret.eq.0 ) then
+c
+ nbtrav = nbtrav + 1
+ litrav(nbtrav) = saux08
+cgn print *,nompro,' 2.3 nbtrav = ', nbtrav
+cgn print *,'litrav(',nbtrav,') = ',saux08
+cgn carenf( 5,nrfonc) = ngauss
+ carenf(21,nrfonc) = advatt
+c
+ endif
+c
+ endif
+c
+c====
+c 7. dans le cas d'un champ aux points de Gauss avec un champ aux
+c noeuds par elements associe, reperage de la fonction associee
+c====
+c
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,*) '7. support Gauss ; codret = ', codret
+#endif
+c
+ if ( carsup.eq.2 ) then
+c
+ if ( codret.eq.0 ) then
+c
+ saux08 = carchf(9,nrfonc)
+cgn call gmprsx (nompro,saux08)
+cgn call gmprsx (nompro,saux08//'.ValeursR')
+c
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,texte(langue,3)) 'UTCAFO', nompro
+#endif
+ call utcafo ( saux08,
+ > typcha,
+ > typgeo, ngausa, nnenma, nnvapa, nbtyaa,
+ > carsua, nbtafa, typina,
+ > anvala, apvane, anobca, anprpa, antyaa,
+ > ulsort, langue, codret )
+c
+ carenf(22,nrfonc) = apvane
+cgn print *,'apvane = ',apvane
+c
+ endif
+c
+ endif
+c
+c====
+c 8. ajout de la fonction au paquet de sortie
+c====
+c
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,*) '8. ajout ; codret = ', codret
+#endif
+c
+ if ( codret.eq.0 ) then
+c
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,texte(langue,3)) 'UTMOPF', nompro
+#endif
+ iaux = 1
+ call utmopf ( nopafo, iaux,
+ > iaux, tbsaux, tbiaux,
+ > nofon2,
+ > nbfopa, jaux, kaux, laux, maux,
+ > adobfo,
+ > ulsort, langue, codret )
+c
+ endif
+c
+#ifdef _DEBUG_HOMARD_
+ call gmprsx (nompro, nopafo )
+ call gmprsx (nompro, nopafo//'.Fonction' )
+ call gmprsx (nompro, nofon2//'.ValeursR' )
+ call gmprsx (nompro, nofon2//'.InfoPrPG' )
+#endif
+c
+c====
+c 9. la fin
+c====
+c
+cgn print *, 'FIN DE ',nompro, ' pour la fonction numero ',nrfonc
+cgn print 1788,(carenf(iaux,nrfonc),iaux=1,nbpara)
+cgn 1788 format(10I8)
+cgn print 1789,(carchf(iaux,nrfonc),iaux=1,9)
+cgn 1789 format(10(a8,1x))
+cgn print *, ' '
+c
+ if ( codret.ne.0 ) then
+c
+#include "envex2.h"
+c
+ write (ulsort,texte(langue,1)) 'Sortie', nompro
+ write (ulsort,texte(langue,2)) codret
+c
+ endif
+c
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,texte(langue,1)) 'Sortie', nompro
+ call dmflsh (iaux)
+#endif
+c
+ end
