1 subroutine pcsono ( numnp1, numnp2, typint, deraff, option,
2 > nbpara, carenf, carchf, nrfonc,
4 > nnoeho, nnoeca, nnosho,
5 > hetare, somare, filare,
7 > hettri, aretri, filtri,
8 > hetqua, arequa, filqua,
9 > tritet, cotrte, aretet,
11 > quahex, coquhe, arehex,
12 > filhex, hethex, fhpyte,
13 > facpen, cofape, arepen,
14 > filpen, hetpen, fppyte,
15 > facpyr, cofapy, arepyr,
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 - Conversion de SOlution - NOeud
39 c ______________________________________________________________________
41 c . nom . e/s . taille . description .
42 c .____________________________________________________________________.
43 c . numnp1 . e . 1 . nombre de noeuds de la fonction si P1 .
44 c . numnp2 . e . 1 . nombre de noeuds de la fonction si P2 .
45 c . typint . e . 1 . type d'interpolation .
46 c . . . . 0, si automatique .
47 c . . . . elements : 0 si intensif, sans orientation.
48 c . . . . 1 si extensif, sans orientation.
49 c . . . . 2 si intensif, avec orientation.
50 c . . . . 3 si extensif, avec orientation.
51 c . . . . noeuds : 1 si degre 1 .
52 c . . . . 2 si degre 2 .
53 c . . . . 3 si iso-P2 .
54 c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en .
55 c . . . . passant de l'iteration n a n+1 ; faux sinon.
56 c . option . e . 1 . option du traitement .
57 c . . . . -1 : Pas de changement dans le maillage .
58 c . . . . 0 : Adaptation complete .
59 c . . . . 1 : Modification de degre .
60 c . nbpara . e . 1 . nombre de parametres a enregistrer par fonc.
61 c . carenf . s .nbpara* . caracteristiques entieres des fonctions : .
62 c . . . nnfopa. 1 : 0, pour une fonction ancienne isolee .
63 c . . . . 1, pour une ancienne associee a une .
64 c . . . . autre fonction .
65 c . . . . -1, pour une nouvelle fonction .
66 c . . . . 2 : typcha .
67 c . . . . 3 : typgeo .
68 c . . . . 4 : typass .
69 c . . . . 5 : ngauss .
70 c . . . . 6 : nnenmx .
71 c . . . . 7 : nnvapr .
72 c . . . . 8 : carsup .
73 c . . . . 9 : nbtafo .
74 c . . . . 10 : anvale .
75 c . . . . 11 : anvalr .
76 c . . . . 12 : anobch .
77 c . . . . 13 : anprpg .
78 c . . . . 14 : anlipr .
79 c . . . . 15 : npenmx .
80 c . . . . 16 : npvapr .
81 c . . . . 17 : apvale .
82 c . . . . 18 : apvalr .
83 c . . . . 19 : apobch .
84 c . . . . 20 : apprpg .
85 c . . . . 21 : apvatt .
86 c . . . . 22 : apvane .
87 c . . . . 23 : antyas .
88 c . . . . 24 : aptyas .
89 c . . . . 25 : numero de la 1ere fonction associee .
90 c . . . . 26 : numero de la 2nde fonction associee .
91 c . carchf . es .nbpara* . caracteristiques caracteres des fonctions :.
92 c . . . nnfopa. 1 : nom de la fonction .
93 c . . . . 2 : nom de la fonction n associee .
94 c . . . . 3 : nom de la fonction p associee .
95 c . . . . 4 : obpcan .
96 c . . . . 5 : obpcap .
97 c . . . . 6 : obprof .
98 c . . . . 7 : oblopg .
99 c . . . . 8 : si aux points de Gauss, nom de la .
100 c . . . . fonction n ELNO correspondante .
101 c . . . . 9 : si aux points de Gauss, nom de la .
102 c . . . . fonction p ELNO correspondante .
103 c . nrfonc . e . 1 . numero de la fonction principale .
104 c . hetnoe . e . nbnoto . historique de l'etat des noeuds .
105 c . ancnoe . e . nbnoto . ancien numero de noeud si deraffinement .
106 c . nnoeho . e . renoto . numero des noeuds en entree pour homard .
107 c . nnoeca . e . renoto . numero des noeuds en entree dans le calcul .
108 c . nnosho . e . rsnoto . numero des noeuds en sortie pour homard .
109 c . hetare . e . nbarto . historique de l'etat des aretes .
110 c . somare . e .2*nbarto. numeros des extremites d'arete .
111 c . filare . e . nbarto . premiere fille des aretes .
112 c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes .
113 c . hettri . e . nbtrto . historique de l'etat des triangles .
114 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
115 c . filtri . e . nbtrto . premier fils des triangles .
116 c . hetqua . e . nbquto . historique de l'etat des quadrangles .
117 c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles .
118 c . filqua . e . nbquto . premier fils des quadrangles .
119 c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres .
120 c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres .
121 c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres .
122 c . filtet . e . nbteto . premier fils des tetraedres .
123 c . hettet . e . nbteto . historique de l'etat des tetraedres .
124 c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres .
125 c . coquhe . e .nbhecf*6. code des 6 quadrangles des hexaedres .
126 c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres .
127 c . filhex . e . nbheto . premier fils des hexaedres .
128 c . hethex . e . nbheto . historique de l'etat des hexaedres .
129 c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide .
130 c . . . . fille de l'hexaedre k tel que filhex(k) =-j.
131 c . . . . fhpyte(2,j) = numero du 1er tetraedre .
132 c . . . . fils de l'hexaedre k tel que filhex(k) = -j.
133 c . facpen . e .nbpecf*5. numeros des faces des pentaedres .
134 c . cofape . e .nbpecf*5. codes des faces des pentaedres .
135 c . filpen . e . nbpeto . premier fils des pentaedres .
136 c . hetpen . e . nbpeto . historique de l'etat des pentaedres .
137 c . arepen . e .nbpeca*9. numeros des 9 aretes des pentaedres .
138 c . fppyte . e .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide .
139 c . . . . fille du pentaedre k tel que filpen(k) =-j .
140 c . . . . fppyte(2,j) = numero du 1er tetraedre .
141 c . . . . fils du pentaedre k tel que filpen(k) = -j .
142 c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides .
143 c . cofapy . e .nbpycf*5. codes des 5 faces des pyramides .
144 c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides .
145 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
146 c . langue . e . 1 . langue des messages .
147 c . . . . 1 : francais, 2 : anglais .
148 c . codret . es . 1 . code de retour des modules .
149 c . . . . 0 : pas de probleme .
150 c . . . . 1 : probleme .
151 c ______________________________________________________________________
154 c 0. declarations et dimensionnement
157 c 0.1. ==> generalites
163 parameter ( nompro = 'PCSONO' )
188 integer numnp1, numnp2
193 integer carenf(nbpara,*)
196 integer hetnoe(nbnoto), ancnoe(nbnoto)
197 integer nnoeho(renoto), nnoeca(renoto)
198 integer nnosho(rsnoto)
199 integer hetare(nbarto), somare(2,nbarto), filare(nbarto)
200 integer np2are(nbarto)
201 integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto)
202 integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto)
203 integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
204 integer filtet(nbteto), hettet(nbteto)
205 integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
206 integer hethex(nbheto), filhex(nbheto), fhpyte(2,nbheco)
207 integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
208 integer filpen(nbpeto), hetpen(nbpeto), fppyte(2,nbpeco)
209 integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
211 character*8 carchf(nbpara,*)
215 integer ulsort, langue, codret
217 c 0.4. ==> variables locales
220 integer codre1, codre2
223 integer typfon, typcha, typgeo, typass
224 integer ngauss, nnenmx, nnvapr, carsup, nbtafo
225 integer n1vale, n1valr, n1obpr, n1obch, n1lipr
226 integer npenmx, npvapr
227 integer p1vale, p1valr, p1obpr, p1obch, p1vatt
228 integer p1vane, p1tyas
229 integer adpcan, adpcap
230 integer nrfon2, nrfon3
231 integer typprf, typin0
233 integer nbfop1, nbfop2
234 integer pvap1h, pvap2h
236 character*8 nofonc, obpcan, obpcap, obprof
238 character*8 nvap1h, nvap2h
241 parameter ( nbmess = 120 )
242 character*80 texte(nblang,nbmess)
244 c 0.5. ==> initialisations
245 c ______________________________________________________________________
254 #ifdef _DEBUG_HOMARD_
255 write (ulsort,texte(langue,1)) 'Entree', nompro
263 texte(1,4) = '(5x,''Fonctions '',a2,'' :'')'
265 > '(5x,''. nombre de noeuds dans leur definition : '',i10)'
267 > '(5x,''. nombre de noeuds dans le maillage initial : '',i10)'
269 > '(5x,''. nombre de valeurs du profil : '',i10)'
270 texte(1,8) = '(''... Premiere(s) valeur(s) : '',5i10)'
271 texte(1,9) = '(''... Dernieres valeurs : '',5i10)'
272 texte(1,10) = '(''. Interpolation '',a)'
274 texte(2,4) = '(5x,''Fonctions '',a2,'' :'')'
276 > '(5x,''. number of nodes in their definition : '',i10)'
278 > '(5x,''. number of nodes in the initial mesh : '',i10)'
280 > '(5x,''. length of profile : '',i10)'
281 texte(2,8) = '(''... First value(s) : '',5i10)'
282 texte(2,9) = '(''... Last value(s) : '',5i10)'
283 texte(2,10) = '(''. '',a,'' interpolation '')'
285 #ifdef _DEBUG_HOMARD_
286 write (ulsort,90002) 'option', option
290 c 2. grandeurs utiles
292 c 2.1. ==> recuperation
294 if ( codret.eq.0 ) then
297 #ifdef _DEBUG_HOMARD_
298 write (ulsort,texte(langue,3)) 'PCFOR2', nompro
300 call pcfor2 ( nbpara, carenf, carchf,
302 > typfon, typcha, typgeo, typass,
303 > ngauss, nnenmx, nnvapr, carsup, nbtafo,
304 > n1vale, n1valr, n1obpr, n1obch, n1lipr,
306 > p1vale, p1valr, p1obpr, p1obch, p1vatt,
310 > obpcan, obpcap, obprof, adpcan, adpcap,
312 > ulsort, langue, codret )
315 cgn write(ulsort,*) 'apres pcfor2'
316 cgn write(ulsort,90002) 'carsup', carsup
317 cgn write(ulsort,90002) 'nnvapr', nnvapr
318 cgn write(ulsort,90002) 'nbtafo', nbtafo
320 c 2.2. ==> type de profil
321 #ifdef _DEBUG_HOMARD_
322 write (ulsort,90002) '2.2. type de profil ; codret', codret
325 if ( codret.eq.0 ) then
327 if ( degre.eq.2 .and. nnvapr.gt.0 ) then
328 #ifdef _DEBUG_HOMARD_
329 write (ulsort,texte(langue,3)) 'PCSPRN', nompro
331 call pcsprn ( typprf, numnp1,
333 > nnvapr, imem(n1lipr) )
343 c 2.3. ==> grandeurs deduites
344 c . Si on n'a rien de special sur le profil, on est fidele
346 c . Sinon, c'est une fonction de degre 1
348 if ( codret.eq.0 ) then
350 if ( typprf.eq.0 ) then
352 if ( degre.eq.1 ) then
367 #ifdef _DEBUG_HOMARD_
368 write (ulsort,90002) 'nbfop1, nbfop2, typint',
369 > nbfop1, nbfop2, typint
370 write (ulsort,texte(langue,7)) nnvapr
371 if ( nnvapr.gt.0 ) then
372 write (ulsort,texte(langue,8))
373 > (imem(iaux),iaux=n1lipr,n1lipr+min(4,nnvapr-1))
374 if ( nnvapr.gt.5 ) then
375 write (ulsort,texte(langue,9))
376 > (imem(iaux),iaux=n1lipr+nnvapr-5,n1lipr+nnvapr-1)
383 c 2.4. ==> verification des coherences de taille
384 #ifdef _DEBUG_HOMARD_
385 write (ulsort,90002) '2.4. verification ; codret', codret
388 if ( codret.eq.0 ) then
390 if ( nnvapr.le.0 ) then
392 if ( nbfop1.ne.0 ) then
393 if ( numnp1.ne.reno1i ) then
394 write (ulsort,texte(langue,4)) 'P1'
395 write (ulsort,texte(langue,5)) numnp1
396 write (ulsort,texte(langue,6)) reno1i
397 write (ulsort,texte(langue,7)) nnvapr
402 if ( nbfop2.ne.0 ) then
403 if ( numnp2.ne.renoto ) then
404 write (ulsort,texte(langue,4)) 'P2'
405 write (ulsort,texte(langue,5)) numnp2
406 write (ulsort,texte(langue,6)) renoto
407 write (ulsort,texte(langue,7)) nnvapr
416 c 2.5. ==> type d'interpolation
417 #ifdef _DEBUG_HOMARD_
418 write (ulsort,90002) '2.5. type interpolation ; codret', codret
421 if ( codret.eq.0 ) then
425 if ( option.eq.1 ) then
426 if ( nbfop1.ne.0 ) then
431 elseif ( typint.eq.0 ) then
432 if ( nbfop1.ne.0 ) then
437 elseif ( typint.eq.1 ) then
439 if ( nbfop1.eq.0 ) then
440 write (ulsort,texte(langue,100+typin0))
441 write (ulsort,texte(langue,117)) 1, nbfop1
444 elseif ( typint.eq.2 .or. typint.eq.3 ) then
446 if ( nbfop2.eq.0 ) then
447 write (ulsort,texte(langue,100+typin0))
448 write (ulsort,texte(langue,117)) 2, nbfop2
455 #ifdef _DEBUG_HOMARD_
456 write (ulsort,90002) 'typin0', typin0
457 if ( typin0.ge.0 .and. typin0.le.5 ) then
458 write (ulsort,texte(langue,100+typin0))
459 write (ulsort,texte(langue,117)) 1, nbfop1
460 write (ulsort,texte(langue,117)) 2, nbfop2
465 c 3. interpolation des variables aux noeuds
466 c remarque : si les fonctions sont inexistantes dans l'une des
467 c categories, on alloue quand meme les tableaux. les
468 c longueurs sont nulles donc on ne perd pas de place.
469 c la lisibilite du programme compense le peu de temps cpu
472 #ifdef _DEBUG_HOMARD_
473 write (ulsort,90002) '3. redistribution ; codret', codret
476 c 3.1. ==> allocations des tableaux intermediaires pour les fonctions
479 if ( codret.eq.0 ) then
481 if ( nbfop1.ne.0 ) then
482 iaux = nbfop1 * max(renoto,nbnoto)
486 call gmalot ( nvap1h, 'reel ', iaux, pvap1h, codre1 )
487 iaux = nbfop2 * max(renoto,nbnoto)
488 call gmalot ( nvap2h, 'reel ', iaux, pvap2h, codre2 )
490 codre0 = min ( codre1, codre2 )
491 codret = max ( abs(codre0), codret,
496 c 3.2. ==> redistribution des valeurs dans la numerotation homard
498 cgn write (*,*) 'fonctions P1'
500 cgn >(rmem(iaux),iaux=n1valr,n1valr-1+nbfop1*max(nnvapr,renoto))
501 cgn write (*,*) 'fonctions P2'
503 cgn >(rmem(iaux),iaux=n1valr,n1valr-1+nbfop2*max(nnvapr,renoto))
505 if ( codret.eq.0 ) then
507 #ifdef _DEBUG_HOMARD_
508 write (ulsort,texte(langue,3)) 'PCSRHO', nompro
510 call pcsrho ( nbfop1, nbfop2, numnp1, numnp2,
514 > nnvapr, imem(n1lipr), imem(adpcan), imem(adpcap),
515 > rmem(n1valr), rmem(n1valr),
516 > rmem(pvap1h), rmem(pvap2h),
517 > ulsort, langue, codret )
520 cgn write (*,*)'apres pcsrho'
521 cgn call gmprsx (nompro, nvap1h )
522 cgn write(*,91011) (imem(adpcap-1+iaux),iaux=2073,2073)
523 cgn write(*,92010) (rmem(pvap1h-1+iaux),iaux=1,nbnoto)
524 cgn write(*,91011) (imem(adpcap-1+iaux),iaux=1,nbnoto)
525 cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto)
526 cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,nbfop2*nbnoto)
529 c 4. Interpolation p1 des variables aux noeuds
532 if ( codret.eq.0 ) then
534 if ( typin0.eq.1 ) then
536 #ifdef _DEBUG_HOMARD_
537 write (ulsort,90002) '4. ==> Interpolation p1 ; codret', codret
540 write (ulsort,texte(langue,10)) 'P1'
542 c 4.1. ==> interpolation p1 pour les aretes decoupees
544 #ifdef _DEBUG_HOMARD_
545 write (ulsort,texte(langue,3)) 'PCS1AR', nompro
547 call pcs1ar ( nbfop1, imem(adpcap),
548 > hetare, somare, filare,
550 cgn write (*,*)'apres pcs1ar'
551 cgn write(*,91011) (imem(adpcap-1+iaux),iaux=2073,2073)
552 cgn write(*,92010) (rmem(pvap1h-1+iaux),iaux=2073,2073)
553 cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto)
554 cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto)
556 c 4.2. ==> interpolation p1 pour les quadrangles decoupes
558 if ( nbquto.ne.0 ) then
560 #ifdef _DEBUG_HOMARD_
561 write (ulsort,texte(langue,3)) 'PCS1QU', nompro
563 call pcs1qu ( nbfop1, imem(adpcap),
565 > hetqua, arequa, filqua,
567 cgn write (*,*)'apres pcs1qu'
568 cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto)
569 cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto)
573 c 4.3. ==> interpolation p1 pour les hexaedres decoupes
575 if ( nbheto.ne.0 ) then
577 cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto)
578 cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto)
579 #ifdef _DEBUG_HOMARD_
580 write (ulsort,texte(langue,3)) 'PCS1HE', nompro
582 call pcs1he ( nbfop1, imem(adpcap),
585 > tritet, cotrte, aretet,
586 > quahex, coquhe, arehex,
587 > filhex, hethex, fhpyte,
588 > facpyr, cofapy, arepyr,
591 cgn write (*,*)'apres pcs1he'
592 cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto)
593 cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto)
596 c 4.3. ==> interpolation p1 pour les pentaedres decoupes
598 if ( nbpeto.ne.0 ) then
600 cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto)
601 cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto)
602 #ifdef _DEBUG_HOMARD_
603 write (ulsort,texte(langue,3)) 'PCS1PE', nompro
605 call pcs1pe ( nbfop1, imem(adpcap),
609 > facpen, cofape, arepen,
610 > filpen, hetpen, fppyte,
611 > facpyr, cofapy, arepyr,
614 cgn write (*,*)'apres pcs1pe'
615 cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto)
616 cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto)
620 c 5. Interpolation p2 des variables aux noeuds
621 c Attention a respecter l'ordre dans l'enchainement des appels
624 elseif ( typin0.eq.2 ) then
626 #ifdef _DEBUG_HOMARD_
627 write (ulsort,90002) '5. Interpolation p2 ; codret', codret
630 write (ulsort,texte(langue,10)) 'P2'
632 c 5.1. ==> pour les aretes decoupees
634 #ifdef _DEBUG_HOMARD_
635 write (ulsort,texte(langue,3)) 'PCS2AR', nompro
637 call pcs2ar ( nbfop2, imem(adpcap), rmem(pvap2h),
638 > hetare, somare, np2are, filare )
639 cgn write (*,*)'apres pcs2ar'
640 cgn write(*,91011) (imem(adpcap-1+iaux),iaux=1,nbnoto)
641 cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,nbfop2*nbnoto-1)
643 cgn > (rmem(pvap2h-1+iaux),iaux=nbfop2*nbnoto-1,nbfop2*nbnoto-1)
645 c 5.2. ==> pour les tetraedres decoupes
647 if ( nbtema.ne.0 ) then
649 #ifdef _DEBUG_HOMARD_
650 write (ulsort,texte(langue,3)) 'PCS2TE', nompro
652 call pcs2te ( nbfop2, imem(adpcap), rmem(pvap2h),
653 > tritet, cotrte, aretet,
660 c 5.3. ==> quadrangles et hexaedres decoupes
661 c Remarque : avec les hexaedres, il faut faire deux passages
662 c pour gerer les raffinements sur deux niveaux
663 c Tant pis si des calculs sont faits deux fois.
666 if ( nbheto.ne.0 ) then
670 do 53 , iaux = 1 , jaux
672 c 5.3.1. ==> pour les quadrangles jaux
674 if ( nbquto.ne.0 ) then
676 #ifdef _DEBUG_HOMARD_
677 write (ulsort,texte(langue,3)) 'PCS2QU', nompro
679 call pcs2qu ( nbfop2, imem(adpcap), rmem(pvap2h),
680 > hetqua, arequa, filqua,
683 cgn write(ulsort,*)'apres pcs2qu'
684 cgn write(ulsort,91011) (imem(adpcap-1+iaux),iaux=1,nbnoto)
685 cgn write(ulsort,92010)(rmem(pvap2h-1+iaux),iaux=1,nbnoto)
689 c 5.3.2. ==> pour les hexaedres decoupes
691 if ( nbheto.ne.0 ) then
693 cgn write (*,*)'avant pcs2he'
694 cgn call gmprsx ( 'avant pcs2he',nvap2h )
695 cgn write(*,91011)(imem(adpcap-1+iaux),iaux=1,nbnoto)
696 cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto)
697 #ifdef _DEBUG_HOMARD_
698 write (ulsort,texte(langue,3)) 'PCS2HE', nompro
700 call pcs2he ( nbfop2, imem(adpcap), rmem(pvap2h),
701 > hethex, quahex, coquhe, arehex,
705 > hetqua, arequa, filqua,
706 > tritet, cotrte, aretet,
707 > facpyr, cofapy, arepyr,
708 > ulsort, langue, codret )
710 cgn write (*,*)'apres pcs2he'
711 cgn write(*,91011)(imem(adpcap-1+iaux),iaux=1,nbnoto)
712 cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,nbfop2*nbnoto)
713 cgn call gmprsx ( 'apres pcs2he',nvap2h )
714 cgn call gmprsx ( 'apres pcs2he',obpcap)
719 c 5.4. ==> pour les pentaedres decoupes
721 if ( nbpeto.ne.0 ) then
723 cgn call gmprsx ( 'avant pcs2pe',nvap2h )
724 cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto)
725 cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto)
726 #ifdef _DEBUG_HOMARD_
727 write (ulsort,texte(langue,3)) 'PCS2PE', nompro
729 call pcs2pe ( nbfop2, imem(adpcap), rmem(pvap2h),
730 > hetpen, facpen, cofape, filpen, fppyte,
735 > ulsort, langue, codret )
737 cgn write (*,*)'apres pcs2pe'
738 cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto)
739 cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,nbfop2*nbnoto)
740 cgn call gmprsx ( 'apres pcs2he',nvap2h )
741 cgn call gmprsx ( 'apres pcs2he',obpcap)
743 cgn call gmprsx ( 'au final',nvap2h )
744 cgn call gmprsx ( 'au final',obpcap)
746 c 5.5. ==> pour les triangles decoupes
748 if ( nbtrma.ne.0 ) then
750 #ifdef _DEBUG_HOMARD_
751 write (ulsort,texte(langue,3)) 'PCS2TR', nompro
753 call pcs2tr ( nbfop2, imem(adpcap), rmem(pvap2h),
754 > hettri, aretri, filtri,
756 cgn write (*,*)'apres pcs2tr'
757 cgn write(*,91011) (imem(adpcap-1+iaux),iaux=1,nbnoto)
758 cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,nbnoto)
760 cgn > (rmem(pvap2h-1+iaux),iaux=nbfop2*nbnoto,nbfop2*nbnoto)
765 c 6. Interpolation iso-p2 des variables aux noeuds
766 c Attention a respecter l'ordre dans l'enchainement des appels
769 elseif ( typin0.eq.3 ) then
771 #ifdef _DEBUG_HOMARD_
772 write (ulsort,90002) '6. Interpolation iso-p2 ; codret', codret
775 write (ulsort,texte(langue,10)) 'iso-P2'
776 cgn write (*,*)'au debut'
777 cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto)
778 cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,2*nbnoto)
780 c 6.1. ==> pour les aretes decoupees
782 #ifdef _DEBUG_HOMARD_
783 write (ulsort,texte(langue,3)) 'PCSIAR', nompro
785 call pcsiar ( nbfop2, imem(adpcap), rmem(pvap2h),
786 > hetare, somare, np2are, filare )
787 cgn write (*,*)'apres pcsiar'
788 cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto)
789 cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,2*nbnoto)
791 c 6.2. ==> pour les tetraedres decoupes
793 if ( nbtema.ne.0 ) then
795 #ifdef _DEBUG_HOMARD_
796 write (ulsort,texte(langue,3)) 'PCSITE', nompro
798 call pcsite ( nbfop2, imem(adpcap), rmem(pvap2h),
799 > tritet, cotrte, aretet,
806 c 6.3. ==> quadrangles et hexaedres decoupes
807 c Remarque : avec les hexaedres, il faut faire deux passages
808 c pour gerer les raffinements sur deux niveaux
809 c Tant pis si des calculs sont faits deux fois.
812 if ( nbheto.ne.0 ) then
816 do 63 , iaux = 1 , jaux
818 c 6.3.1. ==> pour les quadrangles decoupes
820 if ( nbquto.ne.0 ) then
822 #ifdef _DEBUG_HOMARD_
823 write (ulsort,texte(langue,3)) 'PCSIQU', nompro
825 call pcsiqu ( nbfop2, imem(adpcap), rmem(pvap2h),
826 > hetqua, arequa, filqua,
829 cgn write (*,*)'apres pcsiqu'
830 cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto)
831 cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,2*nbnoto)
835 c 6.3.2. ==> pour les hexaedres decoupes
837 if ( nbheto.ne.0 ) then
839 #ifdef _DEBUG_HOMARD_
840 write (ulsort,texte(langue,3)) 'PCSIHE', nompro
842 call pcsihe ( nbfop2, imem(adpcap), rmem(pvap2h),
843 > hethex, quahex, coquhe, arehex,
848 > tritet, cotrte, aretet,
849 > facpyr, cofapy, arepyr )
851 cgn write (*,*)'apres pcs2he'
852 cgn write(*,91011)(imem(adpcap-1+iaux),iaux=1,nbnoto)
853 cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,nbfop2*nbnoto)
854 cgn call gmprsx ( 'apres pcs2he',nvap2h )
855 cgn call gmprsx ( 'apres pcs2he',obpcap)
861 c 6.4. ==> pour les pentaedres decoupes
863 if ( nbpeto.ne.0 ) then
865 cgn call gmprsx ( 'avant pcsipe',nvap2h )
866 cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto)
867 cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*nbnoto)
868 #ifdef _DEBUG_HOMARD_
869 write (ulsort,texte(langue,3)) 'PCSIPE', nompro
871 call pcsipe ( nbfop2, imem(adpcap), rmem(pvap2h),
872 > hetpen, facpen, cofape, filpen, fppyte,
877 > ulsort, langue, codret )
881 c 6.5. ==> pour les triangles decoupes
883 if ( nbtrma.ne.0 ) then
885 #ifdef _DEBUG_HOMARD_
886 write (ulsort,texte(langue,3)) 'PCSITR', nompro
888 call pcsitr ( nbfop2, imem(adpcap), rmem(pvap2h),
889 > hettri, aretri, filtri,
891 cgn write (*,*)'apres pcsitr'
892 cgn write (*,*)(imem(adpcap-1+iaux),iaux=1,nbnoto)
893 cgn write (*,92010)(rmem(pvap2h-1+iaux),iaux=1,2*nbnoto)
898 c 7. Interpolation des variables aux noeuds P1 vers P2
899 c Les nouveaux noeuds P2 sont tous des milieux d'aretes (cf mmcnp2)
902 elseif ( typin0.eq.4 ) then
904 #ifdef _DEBUG_HOMARD_
905 write (ulsort,90002) '7. modification P1 vers P2 ; codret', codret
908 write (ulsort,texte(langue,10)) 'P1'
910 #ifdef _DEBUG_HOMARD_
911 write (ulsort,texte(langue,3)) 'PCSMAR', nompro
913 call pcsmar ( nbfop2, imem(adpcap),
916 cgn write (*,*)'apres pcsmar'
917 cgn write(*,91011) (imem(adpcap-1+iaux),iaux=2073,2073)
918 cgn write(*,92010) (rmem(pvap2h-1+iaux),iaux=1,nbnoto)
921 c 8. Interpolation des variables aux noeuds P2 vers P1
922 c Rien n'est a faire puisque la copie des valeurs sur les noeuds P1
923 c a eu lieu au depart
926 elseif ( typin0.eq.5 ) then
928 #ifdef _DEBUG_HOMARD_
929 write (ulsort,90002) '8. modification P2 vers P1 ; codret', codret
932 write (ulsort,texte(langue,10)) 'P1'
940 #ifdef _DEBUG_HOMARD_
941 write (ulsort,90002) '9. type inconnu ; codret', codret
944 write (ulsort,texte(langue,109))
952 c 10. redistribution des valeurs dans la numerotation du calcul
954 #ifdef _DEBUG_HOMARD_
955 write (ulsort,90002) '10. ==> redistribution ; codret', codret
957 cgn write (ulsort,90002)'avant pcsrc0 : nbfop1, nbfop2',
959 cgn do 888 , iaux = 1 , nbnoto
960 cgn if ( imem(adpcap-1+iaux).eq.0 ) then
961 cgn write(ulsort,*) 'Noeud', iaux
964 cgn write(*,91011) (imem(adpcap-1+iaux),iaux=1,nbnoto)
965 cgn write (*,92010)(rmem(pvap1h-1+iaux),iaux=1,nbfop1*rsnoto-1)
967 if ( nbfop1.ne.0 ) then
969 if ( codret.eq.0 ) then
971 #ifdef _DEBUG_HOMARD_
972 write (ulsort,texte(langue,3)) 'PCSRC0_d1', nompro
974 call pcsrc0 ( nbfop1, rsnoto,
975 > imem(adpcap), nnosho,
976 > rmem(pvap1h), rmem(p1valr) )
978 cgn write (*,*)'apres pcsrc0'
979 cgn write(*,91011) (imem(adpcap-1+iaux),iaux=2073,2073)
980 cgn write(*,92010) (rmem(p1valr-1+iaux),iaux=2073,2073)
981 cgn write(*,92010)(rmem(iaux),iaux=p1valr,p1valr-1+nbfop1*rsnoto-1)
986 if ( nbfop2.ne.0 ) then
988 if ( codret.eq.0 ) then
990 #ifdef _DEBUG_HOMARD_
991 write (ulsort,texte(langue,3)) 'PCSRC0_d2', nompro
993 call pcsrc0 ( nbfop2, rsnoto,
994 > imem(adpcap), nnosho,
995 > rmem(pvap2h), rmem(p1valr) )
996 cgn write (*,*)nbnoto, rsnoto
997 cgn write (*,*)'apres pcsrc0'
998 cgn write (*,92010)(rmem(iaux),iaux=p1valr,p1valr-1+nbfop2*rsnoto)
1000 cgn > (rmem(p1valr-1+iaux),iaux=nbfop2*nbnoto-5,nbfop2*nbnoto)
1001 cgn do 889 , iaux = 1 , nbnoto
1002 cgn if ( imem(adpcap-1+iaux).eq.0 ) then
1003 cgn write(ulsort,*) 'Noeud', iaux
1015 if ( codret.eq.0 ) then
1017 #ifdef _DEBUG_HOMARD_
1018 write (ulsort,texte(langue,3)) 'GMLBOJ', nompro
1021 call gmlboj ( nvap1h, codre1 )
1022 call gmlboj ( nvap2h, codre2 )
1024 codre0 = min ( codre1, codre2 )
1025 codret = max ( abs(codre0), codret,
1034 if ( codret.ne.0 ) then
1038 write (ulsort,texte(langue,1)) 'Sortie', nompro
1039 write (ulsort,texte(langue,2)) codret
1042 cgn write(ulsort,90002)'debut du profil',
1043 cgn > (imem(adpcap+iaux),iaux=0,4)
1044 cgn write(ulsort,90004)'debut des valeurs',
1045 cgn > (rmem(pvap2h+iaux),iaux=0,4)
1046 cgn do 999 , iaux = 1 , nbnoto
1047 cgn if ( imem(adpcap-1+iaux).eq.0 ) then
1048 cgn write(ulsort,90002) 'oubli de', iaux
1052 #ifdef _DEBUG_HOMARD_
1053 write (ulsort,texte(langue,1)) 'Sortie', nompro