1 subroutine gmmodg ( nomtab, lgold, lgnew,
2 > d1old, d1new, d2old, d2new,
3 > adunew, aduold, type8,
4 > minmeg, ntroug, nballg, totalg,
5 > ptroug, ltroug, ptallg, lgallg, adug,
6 > nommxg, nomalg, tablte )
7 c ______________________________________________________________________
11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
14 c aupres des huissiers de justice Simart et Lavoir a Clamart
15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
16 c aupres des huissiers de justice
17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
19 c HOMARD est une marque deposee d'Electricite de France
25 c ______________________________________________________________________
26 c ......................................................................
28 c ......................................................................
31 c . si les tailles sont toutes positives :
32 c on passe de tab(d1old,d2old) a tab(d1new,d2new)
33 c . si les tailles d1x sont negatives et les tailles d2x positives :
34 c on passe de tab(d1old:d2old) a tab(d1new:d2new)
35 c . sinon : probleme ...
36 c . remarque : on peut aussi bien etendre que raccourcir
37 c . remarque : ceci marche meme si une des dimensions reste egale
38 c . a 1 mais ce n'est pas optimal ; il vaut mieux utiliser
39 c . le programme prevu pour les monodimensionnels, gmextg
42 c . reallocation, recopie des donnees,
43 c . suppression de l'original, reaffectation du nom original
46 c . donnees nomtab --> nom du tableau concerne (8 caracteres maxi)
47 c . lgold --> longueur avant
48 c . lgnew --> longueur apres
49 c . d1old --> premiere dimension avant
50 c . d1new --> premiere dimension apres
51 c . d2old --> seconde dimension avant
52 c . d2new --> seconde dimension apres
53 c . type8 --> type du tableau :r,i,s,d
54 c .modifies minmeg <--> valeur entiere memorisant la plus petite
55 c . dimension du dernier trou afin de connaitre
56 c . le passage le plus delicat rencontre au cours
57 c . de l'allocation. cette valeur est calculee
59 c . ntroug <--> valeur entiere . nombre de trous present
60 c . nballg <--> nombre de tableaux deja alloues
61 c . totalg <--> valeur entiere cumulant les demandes
62 c . successives de memoire
63 c . ptroug <--> tableau entier contenant les pointeurs
64 c . repertoriant la position des trous
65 c . ltroug <--> tableau entier contenant la longueur des trous
66 c . ptallg <--> tableau entier contenant les pointeurs
67 c . repertoriant la position des tableaux
68 c . adug <--> adresses utiles des tableaux (retour de gbcara)
69 c . lgallg <--> tableau entier contenant la longueur des
71 c . nommxg <--> chaine de caractere(*8) contenant le nom du
72 c . plus grand tableau associe a minmeg
73 c . nomalg <--> tableau de chaines de caracteres contenant
74 c . le nom associe a chaque tableau deja alloue
75 c .resultat adunew <-- pointeur associe apres extension
76 c . aduold <-- pointeur avant extension
77 c . tablte <-- nom du tableau temporaire
79 c ......................................................................
83 c 0. declarations et dimensionnement
86 c 0.1. ==> generalites
92 parameter ( nompro = 'GMMODG' )
110 integer d1old, d1new, d2old, d2new
113 integer adunew, aduold
114 integer minmeg, ntroug, nballg, totalg
115 integer ptroug(maxtrs) , ltroug(maxtrs)
116 integer ptallg(maxtab) , lgallg(maxtab)
120 character*8 nommxg, nomalg(maxtab)
123 c 0.4. ==> variables locales
128 integer i, icptg, iold
130 integer ltype, ad0, ad1
135 character*1 carint(1)
138 parameter ( nbmess = 10 )
139 character*80 texte(nblang,nbmess)
147 #ifdef _DEBUG_HOMARD_
148 write (ulsort,texte(langue,1)) 'Entree', nompro
158 if ( type8.eq.'i' .or. type8.eq.'I' ) then
163 elseif ( type8.eq.'r' .or. type8.eq.'R' ) then
168 elseif ( type8.eq.'s' .or. type8.eq.'S' ) then
174 write(ulsort,20000) nompro, type8
178 20000 format (//2x,' ****** spg ',a6,' *****',
179 > /2x,'Le type ',a1,' est inconnu.',
180 > /2x,'Il faut r, i ou s',
181 > /2x,' ===> arret dans le gestionnaire de memoire')
187 c 2.1. ==> nature du nom
188 c aucun caractere n'est interdit, mais on met un blanc
189 c dans le tableau pour ne plus avoir de messages ftnchek
191 if ( coergm.eq.0 ) then
195 call gmntve ( nomtab, nomvar, nbcain, carint, coergm )
197 if ( coergm.ne.0 ) then
198 write(ulsort,21100) nompro, nompra
199 21100 format ( 2x,'Probleme a l''appel au spg ',a6,' via ',a6,
200 > /,4x,' ===> arret dans le gestionnaire de memoire')
206 if ( coergm.eq.0 ) then
208 c--- verif que le nom n'est utilise qu'une fois et une seule
212 if ( nomalg(i).eq.nomvar ) then
218 if ( icptg.eq.0 ) then
219 write(ulsort,20003) nompro, nompra, nomvar
220 20003 format ( 2x,'Probleme a l''appel au spg ',a6,' via ',a6,
221 > /,4x,'Le tableau (',a8,') n''a pas ete alloue',
222 > /,4x,' ===> arret dans le gestionnaire de memoire')
223 call ugstop( nompro,ulsort,0,1,1)
224 elseif (icptg.gt.1) then
225 write(ulsort,20013) nompro, nompra, nomvar
226 20013 format ( 2x,'Probleme a l''appel au spg ',a6,' via ',a6,
227 > /,4x,'Le tableau (',a8,') a ete alloue plusieurs fois' ,
228 > /,4x,' ===> arret dans le gestionnaire de memoire')
229 call ugstop( nompro,ulsort,0,1,1)
238 if ( coergm.eq.0 ) then
240 c---- verif que l'ancienne taille correspond bien aux dimensions
243 if ( lgallg(iold).ne.lgold ) then
244 write(ulsort,30001) nompro, nompra, nomvar
245 if ( d1old.gt.0 ) then
246 write(ulsort,30002) d1old, d2old, lgold
248 write(ulsort,30003) -d1old, d2old, lgold
250 write(ulsort,30004) lgallg(iold), d1old, d2old, d1new, d2new
251 30001 format ( 2x,'Probleme a l''appel au spg ',a6,' via ',a6,
252 > /,4x,' pour le tableau ',a)
254 > 4x,'L''ancienne taille annoncee ',i10,' x ',i10,' = ',i10)
256 > 4x,'L''ancienne taille annoncee ',i10,' + ',i10,' = ',i10)
257 30004 format ( 4x,'ne correspond pas a la longueur en memoire ',i10,
258 > /,4x,'Pour memoire, on veut passer de ',
259 > /,4x,'(',i10,' ,',i10,' ) a (',i10,' ,',i10,' )',
260 > /,4x,' ===> arret dans le gestionnaire de memoire')
261 call ugstop( nompro,ulsort,0,1,1)
264 iptold = ptallg(iold)
266 if ( modgm.eq.2 ) then
270 aduold = (iptold-ad0)/ltype
272 c en particulier pour les "gros types",
273 c on n'a pas vraiment de garantie que la division precedente
274 c "tombe juste". Le fait d'avoir en fait alloue un peu plus grand
275 c (cf. appel a gbalme dans gmalog) permet de se mettre a l'abris
276 c de ce genre de probleme (entre autres).
278 if ( aduold*ltype .ge. iptold-ad0 ) then
284 else if ( modgm.eq.1 ) then
285 aduold = ((ad1-ad0)/ltype) + iptold + 1
287 aduold = ((ad1-ad0)/ltype) + iptold
290 c---- en mode non dynamique, s'il n'y a plus de trou : erreur
292 if ( modgm.ne.2 ) then
294 if (ntroug.eq.0) then
295 write(ulsort,30005) nompro, nompra, nomvar
296 30005 format ( 2x,'Probleme a l''appel au spg ',a6,' via ',a6,
297 > /,4x,' pour le tableau ',a8,
298 > /,4x,'Il n''y a plus de place')
299 call ugstop( nompro,ulsort,0,1,1)
307 c 4. contrairement au cas monodimensionnel,
308 c on est oblige de creer un tableau different
309 c ailleurs car le rangement est tel que les memes valeurs ne sont
310 c plus a la meme place
311 c ex a(1,1)=1 a(1,2)=2 a(1,3)=3
312 c a(2,1)=4 a(2,2)=5 a(2,3)=6
313 c le tableau a(2x3) est range ainsi : 1 4 2 5 3 6
314 c s'il devient un tableau a(3x3), les anciennes valeurs seront
315 c mises ainsi : 1 4 x 2 5 x 3 6 x
318 if ( coergm.eq.0 ) then
320 call gbntcr ( tablte )
321 call gmalog ( tablte, adunew, lgnew, type8,
322 > minmeg, ntroug, nballg, totalg,
323 > ptroug, ltroug, ptallg, lgallg,adug,
328 if ( coergm.ne.0 ) then