1 subroutine eslmh3 ( idfmed, nomamd,
3 > nbfmed, natmax, ngrmax,
4 > ulsort, langue, codret)
6 c ______________________________________________________________________
10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
13 c aupres des huissiers de justice Simart et Lavoir a Clamart
14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
15 c aupres des huissiers de justice
16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
18 c HOMARD est une marque deposee d'Electricite de France
24 c ______________________________________________________________________
26 c Entree-Sortie : Lecture du Maillage Homard - phase 3
28 c ______________________________________________________________________
29 c Attention : esemh0 et eslmh3 doivent evoluer en parallelle
30 c ______________________________________________________________________
31 c . nom . e/s . taille . description .
32 c .____________________________________________________________________.
33 c . idfmed . e . 1 . identificateur du fichier MED .
34 c . nomamd . e . char64 . nom du maillage MED voulu .
35 c . nhsupe . e . char8 . informations supplementaires entieres .
36 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
37 c . langue . e . 1 . langue des messages .
38 c . . . . 1 : francais, 2 : anglais .
39 c . codret . es . 1 . code de retour des modules .
40 c . . . . 0 : pas de probleme .
41 c ______________________________________________________________________
44 c 0. declarations et dimensionnement
47 c 0.1. ==> generalites
53 parameter ( nompro = 'ESLMH3' )
81 integer nbfmed, natmax, ngrmax
86 integer ulsort, langue, codret
88 c 0.4. ==> variables locales
92 integer iaux, jaux, kaux, laux
94 integer codre1, codre2
97 integer nbvapr, adlipr
102 parameter ( nbmess = 150 )
103 character*80 texte(nblang,nbmess)
104 c ______________________________________________________________________
112 #ifdef _DEBUG_HOMARD_
113 write (ulsort,texte(langue,1)) 'Entree', nompro
117 texte(1,4) = '(/,5x,''Mise a jour des communs'')'
119 texte(2,4) = '(/,5x,''Updating of commons'')'
126 c 2. Recuperation des parametres essentiels
128 #ifdef _DEBUG_HOMARD_
129 write (ulsort,90002) '2. Lecture des profils ; codret', codret
131 c 2.1. ==> Nombre de profils
133 if ( codret.eq.0 ) then
135 #ifdef _DEBUG_HOMARD_
136 write (ulsort,texte(langue,3)) 'MPFNPF', nompro
138 call mpfnpf ( idfmed, nbprof, codret )
139 #ifdef _DEBUG_HOMARD_
140 write (ulsort,texte(langue,86)) nbprof
145 c 2.2. ==> Parcours des profils
147 do 22 , iaux = 1 , nbprof
149 c 2.2.1. ==> nom et taille du profil a lire
151 if ( codret.eq.0 ) then
155 #ifdef _DEBUG_HOMARD_
156 write (ulsort,texte(langue,3)) 'MPFPFI', nompro
158 call mpfpfi ( idfmed, jaux, noprof, nbvapr, codret )
159 if ( codret.ne.0 ) then
160 write (ulsort,texte(langue,79))
163 #ifdef _DEBUG_HOMARD_
164 write (ulsort,texte(langue,61)) noprof
165 write (ulsort,texte(langue,62)) nbvapr
170 c 2.2.2. ==> On ne continue que pour les InfoSupE
172 if ( codret.eq.0 ) then
174 if ( noprof(10:12).ne.'Tab' ) then
180 c 2.2.3. ==> Allocation du tableau receptacle
182 if ( codret.eq.0 ) then
184 call utlgut ( lgnpro, noprof,
185 > ulsort, langue, codret )
189 if ( codret.eq.0 ) then
191 call utchen ( noprof(13:lgnpro), jaux, ulsort, langue, codret )
195 if ( codret.eq.0 ) then
197 call gmaloj ( nhsupe//'.'//noprof(10:lgnpro) , ' ',
198 > nbvapr, adlipr, codre1 )
199 call gmecat ( nhsupe , jaux, nbvapr, codre2 )
201 codre0 = min ( codre1, codre2 )
202 codret = max ( abs(codre0), codret,
207 c 2.2.4. ==> Lecture de la liste des valeurs
209 if ( codret.eq.0 ) then
210 #ifdef _DEBUG_HOMARD_
211 write (ulsort,texte(langue,3)) 'MPFPRR', nompro
213 call mpfprr ( idfmed, noprof, imem(adlipr), codret )
217 c 2.2.5. ==> Transfert le cas echeant
219 if ( codret.eq.0 ) then
221 c 2.2.5.1. ==> Tab1 : communs entiers
223 if ( jaux.eq.1 ) then
227 nbnois = imem(kaux+1)
228 nbnoei = imem(kaux+2)
229 nbnoma = imem(kaux+3)
230 nbnomp = imem(kaux+4)
231 nbnop1 = imem(kaux+5)
232 nbnop2 = imem(kaux+6)
233 nbnoim = imem(kaux+7)
234 nbnoto = imem(kaux+8)
235 nbpnho = imem(kaux+9)
236 numip1 = imem(kaux+10)
237 numap1 = imem(kaux+11)
238 nbnoin = imem(kaux+12)
241 nbmpto = imem(kaux+1)
242 nbppho = imem(kaux+2)
245 nbarac = imem(kaux+1)
246 nbarde = imem(kaux+2)
247 nbart2 = imem(kaux+3)
248 nbarq2 = imem(kaux+4)
249 nbarq3 = imem(kaux+5)
250 nbarq5 = imem(kaux+6)
251 nbarin = imem(kaux+7)
252 nbarma = imem(kaux+8)
253 nbarpe = imem(kaux+9)
254 nbarto = imem(kaux+10)
255 nbfaar = imem(kaux+11)
256 nbpaho = imem(kaux+12)
259 nbtrac = imem(kaux+1)
260 nbtrde = imem(kaux+2)
261 nbtrt2 = imem(kaux+3)
262 nbtrq3 = imem(kaux+4)
263 nbtrhc = imem(kaux+5)
264 nbtrpc = imem(kaux+6)
265 nbtrtc = imem(kaux+7)
266 nbtrma = imem(kaux+8)
267 nbtrpe = imem(kaux+9)
268 nbtrto = imem(kaux+10)
269 nbptho = imem(kaux+11)
270 nbtrri = imem(kaux+12)
273 nbquac = imem(kaux+1)
274 nbqude = imem(kaux+2)
275 nbquma = imem(kaux+3)
276 nbquq2 = imem(kaux+4)
277 nbquq5 = imem(kaux+5)
278 nbqupe = imem(kaux+6)
279 nbquto = imem(kaux+7)
280 nbpqho = imem(kaux+8)
281 nbquri = imem(kaux+9)
284 nbteac = imem(kaux+1)
285 nbtea2 = imem(kaux+2)
286 nbtea4 = imem(kaux+3)
287 nbtede = imem(kaux+4)
288 nbtef4 = imem(kaux+5)
289 nbteh1 = imem(kaux+6)
290 nbteh2 = imem(kaux+7)
291 nbteh3 = imem(kaux+8)
292 nbteh4 = imem(kaux+9)
293 nbtep0 = imem(kaux+10)
294 nbtep1 = imem(kaux+11)
295 nbtep2 = imem(kaux+12)
296 nbtep3 = imem(kaux+13)
297 nbtep4 = imem(kaux+14)
298 nbtep5 = imem(kaux+15)
299 nbtedh = imem(kaux+16)
300 nbtedp = imem(kaux+17)
301 nbtema = imem(kaux+18)
302 nbtepe = imem(kaux+19)
303 nbteto = imem(kaux+20)
304 nbtecf = imem(kaux+21)
305 nbteca = imem(kaux+22)
308 nbheac = imem(kaux+1)
309 nbheco = imem(kaux+2)
310 nbhede = imem(kaux+3)
311 nbhedh = imem(kaux+4)
312 nbhema = imem(kaux+5)
313 nbhepe = imem(kaux+6)
314 nbheto = imem(kaux+7)
315 nbhecf = imem(kaux+8)
316 nbheca = imem(kaux+9)
319 nbpeac = imem(kaux+1)
320 nbpeco = imem(kaux+2)
321 nbpede = imem(kaux+3)
322 nbpedp = imem(kaux+4)
323 nbpema = imem(kaux+5)
324 nbpepe = imem(kaux+6)
325 nbpeto = imem(kaux+7)
326 nbpecf = imem(kaux+8)
327 nbpeca = imem(kaux+9)
330 nbpyac = imem(kaux+1)
331 nbpyh1 = imem(kaux+2)
332 nbpyh2 = imem(kaux+3)
333 nbpyh3 = imem(kaux+4)
334 nbpyh4 = imem(kaux+5)
335 nbpyp0 = imem(kaux+6)
336 nbpyp1 = imem(kaux+7)
337 nbpyp2 = imem(kaux+8)
338 nbpyp3 = imem(kaux+9)
339 nbpyp4 = imem(kaux+10)
340 nbpyp5 = imem(kaux+11)
341 nbpydh = imem(kaux+12)
342 nbpydp = imem(kaux+13)
343 nbpyma = imem(kaux+14)
344 nbpype = imem(kaux+15)
345 nbpyto = imem(kaux+16)
346 nbpycf = imem(kaux+17)
347 nbpyca = imem(kaux+18)
350 nbfnoe = imem(kaux+1)
351 nbfmpo = imem(kaux+2)
352 nbfare = imem(kaux+3)
353 nbftri = imem(kaux+4)
354 nbfqua = imem(kaux+5)
355 nbftet = imem(kaux+6)
356 nbfhex = imem(kaux+7)
357 nbfpyr = imem(kaux+8)
358 nbfpen = imem(kaux+9)
361 ncffno = imem(kaux+ 1)
362 ncffmp = imem(kaux+ 2)
363 ncffar = imem(kaux+ 3)
364 ncfftr = imem(kaux+ 4)
365 ncffqu = imem(kaux+ 5)
366 ncffte = imem(kaux+ 6)
367 ncffhe = imem(kaux+ 7)
368 ncffpy = imem(kaux+ 8)
369 ncffpe = imem(kaux+ 9)
370 ncefno = imem(kaux+10)
371 ncefmp = imem(kaux+11)
372 ncefar = imem(kaux+12)
373 nceftr = imem(kaux+13)
374 ncefqu = imem(kaux+14)
375 nctfno = imem(kaux+15)
376 nctfmp = imem(kaux+16)
377 nctfar = imem(kaux+17)
378 nctftr = imem(kaux+18)
379 nctfqu = imem(kaux+19)
380 nctfte = imem(kaux+20)
381 nctfhe = imem(kaux+21)
382 nctfpy = imem(kaux+22)
383 nctfpe = imem(kaux+23)
384 ncxfno = imem(iaux+24)
385 ncxfar = imem(iaux+25)
386 ncxftr = imem(iaux+26)
387 ncxfqu = imem(iaux+27)
390 nbiter = imem(kaux+1)
391 nivinf = imem(kaux+2)
392 nivsup = imem(kaux+3)
393 niincf = imem(kaux+4)
394 nisucf = imem(kaux+5)
397 c 2.2.5.2. ==> Tab7 : pointeurs des informations generales
399 elseif ( jaux.eq.7 ) then
402 call gmecat ( nhsupe , jaux, kaux, codret )
410 ccc write (ulsort,90002) 'nbnoto', nbnoto
411 ccc write (ulsort,90002) 'nbmpto', nbmpto
412 ccc write (ulsort,90002) 'nbarto', nbarto
413 ccc write (ulsort,90002) 'nbtrto', nbtrto
414 ccc write (ulsort,90002) 'nbteto', nbteto
415 ccc write (ulsort,90002) 'nbquto', nbquto
416 ccc write (ulsort,90002) 'nbpyto', nbpyto
417 ccc write (ulsort,90002) 'nbheto', nbheto
418 ccc write (ulsort,90002) 'nbpeto', nbpeto
420 cgn call gmprsx (nompro,nhsupe)
424 if ( codret.eq.0 ) then
446 c 3. Recuperation du dimensionnement des familles
448 #ifdef _DEBUG_HOMARD_
449 write (ulsort,90002) '3. Lecture des familles ; codret', codret
452 c 3.1. ==> Nombre de familles
454 if ( codret.eq.0 ) then
456 #ifdef _DEBUG_HOMARD_
457 write (ulsort,texte(langue,3)) 'MFANFA', nompro
459 call mfanfa ( idfmed, nomamd, nbfmed, codret )
461 #ifdef _DEBUG_HOMARD_
462 write (ulsort,texte(langue,29)) nbfmed
467 c 3.2. ==> Recherche des nombres maximaux de groupe
469 if ( codret.eq.0 ) then
474 do 320 , laux = 1 , nbfmed
476 if ( codret.eq.0 ) then
478 #ifdef _DEBUG_HOMARD_
479 write (ulsort,texte(langue,3)) 'MFANFG', nompro
482 ccc call efnatt ( idfmed, nomamd, iaux, jaux, codre1 )
483 call mfanfg ( idfmed, nomamd, iaux, kaux, codret )
484 ccc write (ulsort,90002) 'natt ', jaux
485 ccc write (ulsort,90002) 'ngro ', kaux
489 if ( codret.eq.0 ) then
491 ngrmax = max ( ngrmax, kaux )
498 ccc write (ulsort,90002) 'nbfmed', nbfmed
499 ccc write (ulsort,90002) 'ngrmax', ngrmax
505 if ( codret.ne.0 ) then
509 write (ulsort,texte(langue,1)) 'Sortie', nompro
510 write (ulsort,texte(langue,2)) codret
514 #ifdef _DEBUG_HOMARD_
515 write (ulsort,texte(langue,1)) 'Sortie', nompro