1 subroutine pcfore ( option, extrus,
4 > nbpara, carenf, carchf,
7 > adnohn, admphn, adarhn, adtrhn, adquhn,
8 > adtehn, adpyhn, adhehn, adpehn,
9 > adnocn, admpcn, adarcn, adtrcn, adqucn,
10 > adtecn, adpycn, adhecn, adpecn,
11 > adnoin, admpin, adarin, adtrin, adquin,
12 > adtein, adpyin, adhein, adpein,
13 > lgnoin, lgmpin, lgarin, lgtrin, lgquin,
14 > lgtein, lgpyin, lghein, lgpein,
16 > ulsort, langue, codret )
17 c ______________________________________________________________________
21 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
23 c Version originale enregistree le 18 juin 1996 sous le numero 96036
24 c aupres des huissiers de justice Simart et Lavoir a Clamart
25 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
26 c aupres des huissiers de justice
27 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
29 c HOMARD est une marque deposee d'Electricite de France
35 c ______________________________________________________________________
37 c aPres adaptation - Fonctions - REcuperation
39 c ______________________________________________________________________
41 c . nom . e/s . taille . description .
42 c .____________________________________________________________________.
43 c . option . e . 1 . option du traitement .
44 c . . . . -1 : Pas de changement dans le maillage .
45 c . . . . 0 : Adaptation complete .
46 c . . . . 1 : Modification de degre .
47 c . extrus . e . 1 . prise en compte d'extrusion .
48 c . nnfopa . e . 1 . nombre de fonctions du paquet iteration n .
49 c . anobfo . e . 1 . adresse des noms des fonctions n .
50 c . npfopa . s . 1 . nombre de fonctions du paquet iteration p .
51 c . nppafo . es . 1 . nom du paquet de fonctions iteration p .
52 c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc.
53 c . carenf . s .nbpara* . caracteristiques entieres des fonctions : .
54 c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee .
55 c . . . . 1, pour une ancienne associee a une .
56 c . . . . autre fonction .
57 c . . . . -1, pour une nouvelle fonction .
58 c . . . . 2 : typcha .
59 c . . . . 3 : typgeo .
60 c . . . . 4 : nbtyas .
61 c . . . . 5 : ngauss .
62 c . . . . 6 : nnenmx .
63 c . . . . 7 : nnvapr .
64 c . . . . 8 : carsup .
65 c . . . . 9 : nbtafo .
66 c . . . . 10 : anvale .
67 c . . . . 11 : anvalr .
68 c . . . . 12 : anobch .
69 c . . . . 13 : anprpg .
70 c . . . . 14 : anlipr .
71 c . . . . 15 : npenmx .
72 c . . . . 16 : npvapr .
73 c . . . . 17 : apvale .
74 c . . . . 18 : apvalr .
75 c . . . . 19 : apobch .
76 c . . . . 20 : apprpg .
77 c . . . . 21 : apvatt .
78 c . . . . 22 : apvane .
79 c . . . . 23 : antyas .
80 c . . . . 24 : aptyas .
81 c . . . . 25 : numero de la 1ere fonction associee .
82 c . . . . 26 : numero de la 2nde fonction associee .
83 c . carchf . es .nbpara* . caracteristiques caracteres des fonctions :.
84 c . . . nnfopa. 1 : nom de la fonction .
85 c . . . . 2 : nom de la fonction n associee .
86 c . . . . 3 : nom de la fonction p associee .
87 c . . . . 4 : obpcan .
88 c . . . . 5 : obpcap .
89 c . . . . 6 : obprof .
90 c . . . . 7 : oblopg .
91 c . . . . 8 : si aux points de Gauss, nom de la .
92 c . . . . fonction n ELNO correspondante .
93 c . . . . 9 : si aux points de Gauss, nom de la .
94 c . . . . fonction p ELNO correspondante .
95 c . nbtrav . es . 1 . nombre de tableaux de travail crees .
96 c . litrav . es . * . liste des noms de tableaux de travail crees.
97 c . adnohn . e . 1 . adresse de la renum. des noeuds en entree .
98 c . admphn . e . 1 . adresse de la renum. des m.poi. en entree .
99 c . adarhn . e . 1 . adresse de la renum. des aretes en entree .
100 c . adtrhn . e . 1 . adresse de la renum. des tria. en entree .
101 c . adquhn . e . 1 . adresse de la renum. des quad. en entree .
102 c . adtehn . e . 1 . adresse de la renum. des tetras. en entree .
103 c . adpyhn . e . 1 . adresse de la renum. des pyras. en entree .
104 c . adhehn . e . 1 . adresse de la renum. des hexas. en entree .
105 c . adpehn . e . 1 . adresse de la renum. des pentas. en entree .
106 c . decanu . e . -1:7 . decalage des numerotations selon le type .
107 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
108 c . langue . e . 1 . langue des messages .
109 c . . . . 1 : francais, 2 : anglais .
110 c . codret . es . 1 . code de retour des modules .
111 c . . . . 0 : pas de probleme .
112 c . . . . 1 : probleme .
113 c ______________________________________________________________________
116 c 0. declarations et dimensionnement
119 c 0.1. ==> generalites
125 parameter ( nompro = 'PCFORE' )
135 #ifdef _DEBUG_HOMARD_
153 integer nnfopa, anobfo
156 integer adpetr, adhequ
157 integer carenf(nbpara,*)
158 integer adnohn, admphn, adarhn, adtrhn, adquhn
159 integer adtehn, adpyhn, adhehn, adpehn
160 integer adnocn, admpcn, adarcn, adtrcn, adqucn
161 integer adtecn, adpycn, adhecn, adpecn
162 integer adnoin, admpin, adarin, adtrin, adquin
163 integer adtein, adpyin, adhein, adpein
164 integer lgnoin, lgmpin, lgarin, lgtrin, lgquin
165 integer lgtein, lgpyin, lghein, lgpein
169 character*8 carchf(nbpara,*)
170 character*8 litrav(*)
174 integer ulsort, langue, codret
176 c 0.4. ==> variables locales
178 integer iaux, jaux, kaux, laux, maux, naux
179 integer nrfonc, nrfonm
180 integer nbent2, ngaus2, dimcp2, typge2, nrfon2
181 integer nbent3, ngaus3, dimcp3, typge3, nrfon3
183 integer typfon, typcha, typgeo, nbtyas
184 integer ngauss, nnenmx, nnvapr
185 integer carsup, nbtafo, typint
186 integer anvale, anvalr, anobch, anprpg, antyas
187 integer apvale, apvalr, apobch, apprpg, aptyas
191 integer apobfo, aptyge
192 integer apobfa, aptyga
195 integer reenac, rsenac
196 integer advofa, advohn, advocn
197 integer adenhn, adencn
198 integer lgenin, adenin
199 integer adpcan, adpcap
200 integer tbiaux(nbinec), lgtbix
204 character*8 obpcan, obpcap, oblopg
209 character*8 tbsaux(1)
215 logical afair2, afair3
219 parameter ( nbmess = 120 )
220 character*80 texte(nblang,nbmess)
222 c 0.5. ==> initialisations
223 c ______________________________________________________________________
231 #ifdef _DEBUG_HOMARD_
232 write (ulsort,texte(langue,1)) 'Entree', nompro
238 texte(1,4) = '(/,60(''-''),/,''Fonction '',i3,'', objet = '',a)'
239 texte(1,5) = '(''Type de support geometrique :'',i5)'
240 texte(1,6) = '(''On ne sait pas faire aujourd''''hui.'',/)'
241 texte(1,7) = '(/,''Creation de la fonction a l''''iteration p'')'
242 texte(1,8) = '(/,''Probleme de conformite ?'')'
244 > '(/,''Creation d''''une fonction pour la conformite'')'
245 texte(1,10) = '(''En retour de '',a,'', codret ='',i13)'
246 texte(1,13) = '(''... Premiere valeur : '',g14.7)'
247 texte(1,14) = '(''... Derniere valeur : '',g14.7)'
248 texte(1,15) = '(''... Profil : '',a32)'
249 texte(1,16) = '(''... Premiere(s) valeur(s) : '',5i10)'
250 texte(1,17) = '(''... Derniere(s) valeur(s) : '',5i10)'
252 > '(''Les deux longueurs de profil sont differentes !'')'
253 texte(1,19) = '(''Caracteristiques du support :'',i5)'
255 texte(2,4) = '(/,60(''-''),/,''Function '',i3,'', objet = '',a)'
256 texte(2,5) = '(''Geometric support type :'',i5)'
257 texte(2,6) = '(''It cannot be solved.'',/)'
258 texte(2,7) = '(/,''Creation of a function for iteration # p'')'
259 texte(2,8) = '(/,''Pending nodes ?'')'
260 texte(2,9) = '(/,''Creation of a function for pending nodes'')'
261 texte(2,10) = '(''Back from '',a,'', codret ='',i13)'
262 texte(2,13) = '(''... First value : '',g14.7)'
263 texte(2,14) = '(''... Last value : '',g14.7)'
264 texte(2,15) = '(''... Profile : '',a32)'
265 texte(2,16) = '(''... First value(s) : '',5i10)'
266 texte(2,17) = '(''... Last value(s) : '',5i10)'
268 > '(''The two lengths of profile are not the same !'')'
269 texte(2,19) = '(''Characteristics of the support:'',i5)'
277 c 2. prealable pour les couples (aux noeuds par element/aux points
281 c 2.1. ==> decodage de nppafo, paquet a l'iteration p
283 #ifdef _DEBUG_HOMARD_
284 cgn call gmprsx (nompro,nppafo)
285 cgn call gmprsx (nompro,nppafo//'.Fonction')
286 cgn call gmprsx (nompro,nppafo//'.TypeSuAs')
287 write (ulsort,texte(langue,3)) 'UTCAPF', nompro
289 call utcapf ( nppafo,
290 > iaux, jaux, kaux, laux, maux,
292 > ulsort, langue, codret )
294 c 2.2. ==> si c'est un champ aux points de Gauss, on repere nppafa,
295 c paquet correspondant, a l'iteration p.
297 if ( laux.eq.2 ) then
299 if ( codret.eq.0 ) then
301 nppafa = smem(apobfo+npfopa)
302 cgn write (ulsort,*) 'Paquet correspondant ==> ',nppafa
304 #ifdef _DEBUG_HOMARD_
305 write (ulsort,texte(langue,3)) 'UTCAPF', nompro
306 call gmprsx (nompro,nppafa)
307 call gmprsx (nompro,nppafa//'.Fonction')
309 call utcapf ( nppafa,
310 > iaux, jaux, kaux, laux, maux,
312 > ulsort, langue, codret )
319 c 3. parcours des fonctions du paquet a l'iteration n
322 do 30 , nrfonc = 1 , nnfopa
324 nnfonc = smem(anobfo+nrfonc-1)
326 #ifdef _DEBUG_HOMARD_
327 write (ulsort,texte(langue,4)) nrfonc, nnfonc
328 call gmprsx (nompro,nnfonc)
329 call gmprsx (nompro,nnfonc//'.InfoPrPG')
330 call gmprsx (nompro,nnfonc//'.TypeSuAs')
333 c 3.1. ==> caracteristiques de la fonction a l'iteration n
335 if ( codret.eq.0 ) then
337 #ifdef _DEBUG_HOMARD_
338 write (ulsort,texte(langue,3)) 'UTCAFO', nompro
340 call utcafo ( nnfonc,
342 > typgeo, ngauss, nnenmx, nnvapr, nbtyas,
343 > carsup, nbtafo, typint,
344 > anvale, anvalr, anobch, anprpg, antyas,
345 > ulsort, langue, codret )
347 #ifdef _DEBUG_HOMARD_
348 write (ulsort,texte(langue,10)) 'utcafo', codret
352 oblopg = smem(anprpg+1)
356 if ( codret.eq.0 ) then
358 #ifdef _DEBUG_HOMARD_
359 write (ulsort,90002) 'typgeo', typgeo
360 write (ulsort,90002) 'ngauss', ngauss
361 write (ulsort,90002) 'nnenmx', nnenmx
362 write (ulsort,90002) 'nnvapr', nnvapr
363 write (ulsort,90002) 'nbtyas', nbtyas
364 if ( nbtyas.gt.0 ) then
366 > '==> typass', (imem(antyas+iaux-1),iaux=1,nbtyas)
368 write (ulsort,90002) 'carsup', carsup
369 write (ulsort,90002) 'nbtafo', nbtafo
370 write (ulsort,*) '.. oblopg : ', oblopg
371 cgn write (ulsort,texte(langue,13)) rmem(anvalr)
372 cgn write (ulsort,texte(langue,14))
373 cgn > rmem(anvalr+nnenmx*nbtafo*nbpg-1)
376 if ( nbtyas.ge.1 ) then
381 carenf( 1,nrfonc) = typfon
382 carenf( 2,nrfonc) = typcha
383 carenf( 3,nrfonc) = typgeo
384 carenf( 4,nrfonc) = nbtyas
385 carenf( 5,nrfonc) = nbpg
386 carenf( 6,nrfonc) = nnenmx
387 carenf( 7,nrfonc) = nnvapr
388 carenf( 8,nrfonc) = carsup
389 carenf( 9,nrfonc) = nbtafo
390 carenf(10,nrfonc) = anvale
391 carenf(11,nrfonc) = anvalr
392 carenf(12,nrfonc) = anobch
393 carenf(13,nrfonc) = anprpg
394 carenf(23,nrfonc) = antyas
396 carchf( 2,nrfonc) = nnfonc
397 carchf( 7,nrfonc) = oblopg
401 c 3.2. ==> pour une fonction aux points de Gausss avec un champ aux
402 c noeuds par elements associe, la fonction associee
404 if ( carsup.eq.2 ) then
406 if ( codret.eq.0 ) then
408 carchf(8,nrfonc) = smem(anprpg+2)
409 carchf(9,nrfonc) = smem(apobfa+nrfonc-1)
410 cgn call gmprsx (nompro,carchf(9,nrfonc))
416 c 3.3. ==> le profil eventuel
418 if ( nnvapr.gt.0 ) then
420 c 3.3.1. ==> les caracteristiques du profil
422 if ( codret.eq.0 ) then
424 #ifdef _DEBUG_HOMARD_
425 write (ulsort,texte(langue,3)) 'UTCAPR', nompro
427 call utcapr ( smem(anprpg),
428 > jaux, noprof, anlipr,
429 > ulsort, langue, codret )
433 if ( codret.eq.0 ) then
435 #ifdef _DEBUG_HOMARD_
436 write (ulsort,texte(langue,10)) 'utcapr', codret
437 write (ulsort,texte(langue,13)) 'jaux', jaux
438 write (ulsort,texte(langue,15)) noprof
439 write (ulsort,texte(langue,16))
440 > (imem(anlipr+iaux),iaux=0,min(4,jaux-1))
441 if ( nnvapr.gt.5 ) then
442 write (ulsort,texte(langue,17))
443 > (imem(anlipr+iaux),iaux=jaux-5,jaux-1)
447 c 3.3.2. ==> on verifie que les longueurs sont bien les memes : celle
448 c enregistree dans le profil, jaux, et celle enregistree
449 c dans la fonction, nnvapr.
451 if ( jaux.ne.nnvapr ) then
452 write (ulsort,90002) 'nnvapr', nnvapr
453 write (ulsort,90002) 'jaux ', jaux
454 write (ulsort,texte(langue,18))
458 carenf(14,nrfonc) = anlipr
464 c 3.4. ==> creation de fonctions associees pour la conformite :
465 c . quand la fonction courante est definie sur des quadrangles,
466 c des hexaedres ou des pentaedres
467 c . que des mailles de conformite sont presentes
468 c . qu'il n'a pas de fonction associee sur ces mailles de conformite
470 #ifdef _DEBUG_HOMARD_
471 write (ulsort,90002) '3.4. creer une fonction ; codret', codret
474 if ( codret.eq.0 ) then
476 #ifdef _DEBUG_HOMARD_
477 write (ulsort,texte(langue,8))
478 write (ulsort,90002) 'typgeo', typgeo
479 write (ulsort,90002) 'nbtyas', nbtyas
480 write (ulsort,90002) 'ngauss', ngauss
481 write (ulsort,90002) 'nbtafo', nbtafo
482 write (ulsort,90002) 'nbtrq3', nbtrq3
483 write (ulsort,90002) 'nbheco', nbheco
484 write (ulsort,90002) 'nbpeco', nbpeco
485 write (ulsort,90002) 'nbtyas', nbtyas
496 if ( ( typgeo.eq.edqua4 .or. typgeo.eq.edqua8 ) .and.
498 if ( typgeo.eq.edqua4 ) then
501 if ( carsup.eq.1 ) then
504 elseif ( carsup.eq.2 .or. carsup.eq.3 ) then
510 if ( carsup.eq.1 ) then
513 elseif ( carsup.eq.2 .or. carsup.eq.3 ) then
518 do 341 , iaux = 1 , nbtyas
519 if ( imem(antyas+iaux-1).eq.typge2 ) then
525 elseif ( ( ( typgeo.eq.edhex8 .or. typgeo.eq.edhe20 ) .and.
527 > ( ( typgeo.eq.edpen6 .or. typgeo.eq.edpe15 ) .and.
528 > nbpeco.ne.0 ) ) then
529 if ( typgeo.eq.edhex8 .or. typgeo.eq.edpen6 ) then
534 if ( carsup.eq.1 ) then
539 elseif ( carsup.eq.2 .or. carsup.eq.3 ) then
542 elseif ( typgeo.eq.edhe20 .or. typgeo.eq.edpe15 ) then
547 if ( carsup.eq.1 ) then
552 elseif ( carsup.eq.2 .or. carsup.eq.3 ) then
560 do 342 , iaux = 1 , nbtyas
561 if ( imem(antyas+iaux-1).eq.typge2 ) then
565 if ( imem(antyas+iaux-1).eq.typge3 ) then
573 if ( codret.ne.0 ) then
575 write (ulsort,texte(langue,5)) typgeo
576 write (ulsort,texte(langue,19)) carsup
577 write (ulsort,texte(langue,68))
578 write (ulsort,texte(langue,6))
584 #ifdef _DEBUG_HOMARD_
585 write (ulsort,99001) 'afair2', afair2
586 write (ulsort,99001) 'afair3', afair3
589 c 3.5. ==> bilan sur les types
590 #ifdef _DEBUG_HOMARD_
591 write (ulsort,90002) '3.5. bilan type ; codret', codret
594 if ( codret.eq.0 ) then
596 c memorisation des eventuels types associes deja presents
599 do 35 , iaux = 1 , nbtyas
601 tbiaux(lgtbix) = imem(antyas+iaux-1)
604 c si conformite, ajout du type courant et du/des types associes
606 if ( afair2 .or. afair3 ) then
609 tbiaux(lgtbix) = typgeo
612 tbiaux(lgtbix) = typge2
616 tbiaux(lgtbix) = typge3
621 #ifdef _DEBUG_HOMARD_
622 write (ulsort,90002) 'tbiaux = ', (tbiaux(iaux),iaux=1,lgtbix)
626 c 3.6. ==> la fonction similaire a l'iteration p
627 #ifdef _DEBUG_HOMARD_
628 write (ulsort,90002) '3.6. similaire ; codret', codret
631 if ( codret.eq.0 ) then
633 #ifdef _DEBUG_HOMARD_
634 write (ulsort,texte(langue,7))
637 if ( typgeo.eq.0 ) then
639 elseif ( typgeo.eq.edseg2 .or. typgeo.eq.edseg3 ) then
641 elseif ( typgeo.eq.edtri3 .or. typgeo.eq.edtri6 ) then
643 elseif ( typgeo.eq.edqua4 .or. typgeo.eq.edqua8 ) then
645 elseif ( typgeo.eq.edtet4 .or. typgeo.eq.edte10 ) then
647 elseif ( typgeo.eq.edhex8 .or. typgeo.eq.edhe20 ) then
649 elseif ( typgeo.eq.edpyr5 .or. typgeo.eq.edpy13 ) then
651 elseif ( typgeo.eq.edpen6 .or. typgeo.eq.edpe15 ) then
654 write (ulsort,texte(langue,5)) typgeo
655 write (ulsort,texte(langue,6))
661 if ( codret.eq.0 ) then
664 #ifdef _DEBUG_HOMARD_
665 write (ulsort,texte(langue,3)) 'PCFOR1_p', nompro
667 call pcfor1 ( option,
669 > nbpara, carenf, carchf,
672 > typfon, typcha, typgeo, nbtyas,
673 > ngauss, nbsufo, nnvapr,
674 > carsup, nbtafo, typint,
676 > apvale, apvalr, apobch, apprpg, aptyas,
678 > ulsort, langue, codret )
682 c 3.7. ==> pour les champs aux noeuds par elements, creation de la
683 c localisation des pseudo "points de Gauss"
684 c REMARQUE : on ne cree plus rien
685 #ifdef _DEBUG_HOMARD_
686 write (ulsort,90002) '3.7. pseudo ; codret', codret
687 write (ulsort,90002) 'carsup', carsup
688 write (ulsort,99001) 'afair2', afair2
689 write (ulsort,99001) 'afair3', afair3
692 if ( afair2 .and. carsup.eq.1793 ) then
694 if ( codret.eq.0 ) then
696 #ifdef _DEBUG_HOMARD_
697 write (ulsort,texte(langue,3)) 'UTCRPG-2', nompro
699 call utcrpg ( oblop2,
700 > nolop2, typge2, ngaus2, dimcp2, carsup,
701 > ulsort, langue, codret )
711 if ( afair3 .and. carsup.eq.1793 ) then
713 if ( codret.eq.0 ) then
715 #ifdef _DEBUG_HOMARD_
716 write (ulsort,texte(langue,3)) 'UTCRPG-3', nompro
718 call utcrpg ( oblop3,
719 > nolop3, typge3, ngaus3, dimcp3, carsup,
720 > ulsort, langue, codret )
730 #ifdef _DEBUG_HOMARD_
731 write (ulsort,90003) 'oblop2', oblop2
732 write (ulsort,90003) 'oblop3', oblop3
735 c 3.8. ==> creation des fonctions pour la conformite
736 #ifdef _DEBUG_HOMARD_
737 write (ulsort,90002) '3.8. conformite ; codret', codret
739 c 3.8.1. ==> 1ere fonction
743 if ( codret.eq.0 ) then
745 #ifdef _DEBUG_HOMARD_
746 write (ulsort,texte(langue,9))
753 #ifdef _DEBUG_HOMARD_
754 write (ulsort,texte(langue,3)) 'PCFOR1_2', nompro
756 call pcfor1 ( option,
758 > nbpara, carenf, carchf,
761 > typfon, typcha, typge2, nbtyas,
762 > ngaus2, nbent2, laux,
763 > carsup, nbtafo, typint,
765 > apvale, apvalr, apobch, apprpg, aptyas,
767 > ulsort, langue, codret )
769 carchf( 2,nrfon2) = nnfonc
770 carchf( 3,nrfon2) = carchf( 1,nrfonc)
771 carchf( 7,nrfon2) = oblop2
777 c 3.8.2. ==> 2nde fonction
781 if ( codret.eq.0 ) then
783 #ifdef _DEBUG_HOMARD_
784 write (ulsort,texte(langue,9))
791 #ifdef _DEBUG_HOMARD_
792 write (ulsort,texte(langue,3)) 'PCFOR1_3', nompro
794 call pcfor1 ( option,
796 > nbpara, carenf, carchf,
799 > typfon, typcha, typge3, nbtyas,
800 > ngaus3, nbent3, laux,
801 > carsup, nbtafo, typint,
803 > apvale, apvalr, apobch, apprpg, aptyas,
805 > ulsort, langue, codret )
807 carchf( 2,nrfon3) = nnfonc
808 carchf( 3,nrfon3) = carchf( 1,nrfonc)
809 carchf( 7,nrfon3) = oblop3
815 c 3.9. ==> modification des types associes du paquet de fonction
816 #ifdef _DEBUG_HOMARD_
817 write (ulsort,90002) '3.9. modification ; codret', codret
820 if ( afair2 .or. afair3 ) then
822 if ( codret.eq.0 ) then
824 #ifdef _DEBUG_HOMARD_
825 write (ulsort,texte(langue,3)) 'UTMOPF', nompro
828 call utmopf ( nppafo, iaux,
829 > lgtbix, tbsaux, tbiaux,
831 > jaux, nbtyas, ngauss, laux, maux,
833 > ulsort, langue, codret )
839 #ifdef _DEBUG_HOMARD_
840 if ( codret.eq.0 ) then
841 call gmprsx (nompro, nppafo )
842 call gmprsx (nompro, nppafo//'.Fonction' )
843 call gmprsx (nompro, nppafo//'.TypeSuAs')
847 c 3.10. ==> Enregistrement des numeros de fonctions associees,
848 c reelles ou fictives
850 if ( codret.eq.0 ) then
852 #ifdef _DEBUG_HOMARD_
853 write (ulsort,90002) 'nrfon2', nrfon2
854 write (ulsort,90002) 'nrfon3', nrfon3
857 carenf(25,nrfonc) = nrfon2
858 carenf(26,nrfonc) = nrfon3
865 c 4. preparation des profils des fonctions du paquet
867 #ifdef _DEBUG_HOMARD_
868 write (ulsort,90002) '4. Preparation ; codret', codret
871 do 40 , nrfonc = 1 , nrfonm
873 cgn print 1788,(carenf(iaux,nrfonc),iaux=1,nbpara)
875 c 4.1. ==> recuperation des informations
877 if ( codret.eq.0 ) then
879 typgeo = carenf( 3,nrfonc)
880 nnvapr = carenf( 7,nrfonc)
881 anlipr = carenf(14,nrfonc)
882 #ifdef _DEBUG_HOMARD_
883 write (ulsort,90002) 'typgeo', typgeo
884 write (ulsort,90002) 'nnvapr', nnvapr
888 if ( typgeo.eq.0 ) then
896 elseif ( typgeo.eq.edpoi1 ) then
904 elseif ( typgeo.eq.edseg2 .or. typgeo.eq.edseg3 ) then
912 elseif ( typgeo.eq.edtri3 .or. typgeo.eq.edtri6 ) then
924 elseif ( typgeo.eq.edqua4 .or. typgeo.eq.edqua8 ) then
936 elseif ( typgeo.eq.edtet4 .or. typgeo.eq.edte10 ) then
944 elseif ( typgeo.eq.edpyr5 .or. typgeo.eq.edpy13 ) then
952 elseif ( typgeo.eq.edhex8 .or. typgeo.eq.edhe20 ) then
960 elseif ( typgeo.eq.edpen6 .or. typgeo.eq.edpe15 ) then
974 c 4.2. ==> tableau reciproque de nenin
976 if ( lgenin.gt.0 .and. nnvapr.gt.0 ) then
978 if ( codret.eq.0 ) then
980 call gmalot ( ntrav1, 'entier ', reenac, adtra1, codret )
984 if ( codret.eq.0 ) then
987 #ifdef _DEBUG_HOMARD_
988 write (ulsort,texte(langue,3)) 'UTTBRC', nompro
991 > lgenin, imem(adenin), reenac, imem(adtra1),
992 > ulsort, langue, codret)
998 c 4.3. ==> prise en compte du profil
1000 #ifdef _DEBUG_HOMARD_
1001 write (ulsort,90002) 'nnvapr', nnvapr
1002 write (ulsort,90002) 'reenac', reenac
1003 write (ulsort,90002) 'rsenac', rsenac
1004 write (ulsort,90002) 'decala', decala
1005 write (ulsort,99001) 'extrul', extrul
1008 if ( .not.extrul ) then
1010 if ( codret.eq.0 ) then
1013 #ifdef _DEBUG_HOMARD_
1014 write (ulsort,texte(langue,3)) 'UTPR05', nompro
1016 call utpr05 ( iaux, nnvapr, imem(anlipr),
1018 > imem(adenhn), imem(adencn), decala,
1019 > lgenin, imem(adenin), imem(adtra1),
1022 > ulsort, langue, codret )
1028 if ( codret.eq.0 ) then
1031 #ifdef _DEBUG_HOMARD_
1032 write (ulsort,texte(langue,3)) 'UTPR06', nompro
1036 > imem(advofa), imem(adenhn),
1037 > imem(advohn), imem(advocn),
1040 > ulsort, langue, codret )
1045 cgn call gmprsx (nompro,obpcap)
1047 c 4.4. ==> archivage
1049 if ( codret.eq.0 ) then
1051 carchf (4,nrfonc) = obpcan
1053 litrav(nbtrav) = obpcan
1054 cgn write (ulsort,*)'4.3 nbtrav =', nbtrav,', obpcan = ', obpcan
1055 cgn print *,'litrav(',nbtrav,') = ',litrav(nbtrav)
1057 carchf (5,nrfonc) = obpcap
1059 litrav(nbtrav) = obpcap
1060 cgn write (ulsort,*)'4.3 nbtrav =', nbtrav,', obpcap = ', obpcap
1061 cgn print *,'litrav(',nbtrav,') = ',litrav(nbtrav)
1065 nnfonc = carchf(1,nrfonc)
1066 cgn write (*,texte(langue,4)) nrfonc, nnfonc
1067 cgn write (*,1788)(carenf(iaux,nrfonc),iaux=1,nbpara)
1068 cgn 1788 format(10I8)
1069 cgn write (*,1789)(carchf(iaux,nrfonc),iaux=1,nbpara)
1070 cgn 1789 format(10(a8,1x))
1074 if ( lgenin.gt.0 .and. nnvapr.gt.0 ) then
1076 if ( codret.eq.0 ) then
1078 call gmlboj ( ntrav1 , codret )
1090 if ( codret.ne.0 ) then
1094 write (ulsort,texte(langue,1)) 'Sortie', nompro
1095 write (ulsort,texte(langue,2)) codret
1099 #ifdef _DEBUG_HOMARD_
1100 write (ulsort,texte(langue,1)) 'Sortie', nompro