--- /dev/null
+ subroutine gmcmpr ( 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 - interet:
+c . Aucun en mode dynamique de gestion de la memoire !!!!!
+c . En mode statique, on elimine les trous laisses entre les
+c differents tableaux entiers, reels et character*8
+c de maniere a offrir le maximum de place disponible en un seul
+c trou situe en fin des tableaux de travail.
+c attention la reallocation se fait sans reinitialiser la memoire
+c en mettant lindef a 1. lindef est remis a 0 en fin de programme.
+c
+c La technique est la suivante :
+c Tant qu'il reste au moins deux trous (en effet, s'il n'en reste
+c qu'un, il est forcement a la fin, donc c'est gagne !) :
+c a. recherche du premier tableau qui suit le premier trou.
+c b. memorisation de son nom, son adresse utile, sa longueur
+c c. retrait de ses references des tables de GM
+c d. allocation d'un tableau de meme nom et de meme longueur : GM
+c va forcement le placer au debut du premier trou et creer
+c un trou a sa suite
+c e. si le tableau n'est pas de longueur nulle, decalage du contenu
+c
+c - restriction d'utilisation
+c apres cet appel, il faut prendre soin de rechercher
+c les nouveaux pointeurs des tableaux toujours en usage par appel
+c a gmadoj
+c
+c ______________________________________________________________________
+c . . . . .
+c . nom . e/s . taille . description .
+c .____________________________________________________________________.
+c . codret . s . ent . code retour de l'operation .
+c . . . . 0 : OK .
+c . . . . 2 : probleme .
+c ______________________________________________________________________
+c
+c====
+c 0. declarations et dimensionnement
+c====
+c
+c 0.1. ==> generalites
+c
+ implicit none
+ save
+c
+#include "gmmaxt.h"
+c
+c 0.2. ==> communs
+c
+#include "gmtyge.h"
+c
+#include "gmenti.h"
+#include "gmreel.h"
+#include "gmstri.h"
+c
+#include "gmtrrl.h"
+#include "gmtren.h"
+#include "gmtrst.h"
+c
+#include "gmalrl.h"
+#include "gmalen.h"
+#include "gmalst.h"
+c
+#include "gmadui.h"
+#include "gmadur.h"
+#include "gmadus.h"
+c
+#include "gmimpr.h"
+c
+#include "gmindf.h"
+c
+c 0.3. ==> arguments
+c
+ integer codret
+c
+c 0.4. ==> variables locales
+c
+ character*8 nomtab
+ character*16 blabla
+c
+ integer aduold, ilongr, adunew, iptfin
+ integer iaux, ideb, nrotab
+c
+ logical detlg0
+c
+c 0.5. ==> initialisations
+c
+ detlg0 = .true.
+c ______________________________________________________________________
+c
+#ifdef _DEBUG_HOMARD_
+ write(ulsort,*) 'Compression de la memoire'
+#endif
+c
+#include "impr03.h"
+c
+c====
+c 1. Pas de compression en mode dynamique
+c====
+c
+ if ( modgm.eq.2) then
+c
+ codret = 0
+#ifdef _DEBUG_HOMARD_
+ write(ulsort,*) 'impossible en mode dynamique'
+#endif
+c
+ else
+c
+ lindef = 1
+c
+10000 format (//2x,' ======= spg gmcmpr ==========',/2x,
+ > 'Zone en ',a16,/2x,
+ > 'le trou debutant en ',i4,' et de longueur ',i4,/2x,
+ > 'n''est pas contigu a un tableau entier alloue --> probleme')
+c
+c====
+c 2. traitement du tableau reel
+c====
+c
+#ifdef _DEBUG_HOMARD_
+ call gmdmpr ( iaux )
+#endif
+c
+ nrotab = 0
+c
+ 2 continue
+c
+ if ( ntrour.gt.1 ) then
+c
+ blabla = 'reel '
+c
+c 2.1. ==> on cherche le premier tableau alloue qui suit le trou "1"
+c il suffit d'explorer a partir du dernier trouve
+c
+ iptfin = ptrour(1) + ltrour(1)
+c
+ ideb = nrotab + 1
+ do 21 , iaux = ideb , nballr
+ if ( ptallr(iaux).eq.iptfin ) then
+ nrotab = iaux
+ goto 22
+ endif
+ 21 continue
+c
+c --> pb de consistance entre les trous et les variables allouees
+c
+ write(ulsort,10000) blabla, ptrour(1), ltrour(1)
+ iaux = 3
+ call gmdmpr ( iaux )
+ call ugstop ( 'gmcmpr-reel', ulsort, 0, 1, 1 )
+c
+c 2.2. ==> on libere ce tableau (apres avoir memorise ses
+c caracteristiques)
+c
+ 22 continue
+c
+ aduold = adur(nrotab)
+ ilongr = lgallr(nrotab)
+ nomtab = nomalr(nrotab)
+c
+ call gmdesr ( nomtab , ilongr , detlg0)
+c
+c 2.3. ==> on le realloue (--> on detruit ainsi le trou precedant
+c qui se propage vers la droite )
+c attention, l'adresse renvoyee est l'adresse utile
+c
+ call gmalor ( nomtab , adunew , ilongr )
+c
+c 2.4. ==> on translate son contenu de l'ancienne position a la nouvelle
+c si le tableau n'est pas de longueur nulle
+c
+ if ( ilongr.ne.0 ) then
+ call gmshfr ( rmem , adunew , aduold , ilongr )
+ endif
+c
+c 2.5. ==> on recommence jusqu'a epuisement
+c
+ goto 2
+c
+ endif
+c
+#ifdef _DEBUG_HOMARD_
+ call gmdmpr ( iaux )
+#endif
+c
+c====
+c 3. traitement du tableau entier
+c on n'effectue un passage que s'il existe plusieurs trous dans
+c le tableau, car quand il n'y en a qu'un, il est au bout.
+c====
+c
+#ifdef _DEBUG_HOMARD_
+ call gmdmpi ( iaux )
+#endif
+c
+ nrotab = 0
+c
+ 3 continue
+c
+ if ( ntroui.gt.1 ) then
+c
+ blabla = 'entier '
+c
+c 3.1. ==> on cherche le premier tableau alloue qui suit le trou "1"
+c il suffit d'explorer a partir du dernier trouve
+c
+ iptfin = ptroui(1) + ltroui(1)
+c
+ ideb = nrotab + 1
+ do 31 , iaux = ideb , nballi
+ if ( ptalli(iaux).eq.iptfin ) then
+ nrotab = iaux
+ goto 32
+ endif
+ 31 continue
+c
+c --> pb de consistance entre les trous et les variables allouees
+c
+ write(ulsort,10000) blabla, ptroui(1), ltroui(1)
+ iaux = 3
+ call gmdmpi ( iaux )
+ call ugstop ( 'gmcmpr_entier', ulsort, 0, 1, 1 )
+c
+c 3.2. ==> on libere ce tableau (apres avoir memorise ses
+c caracteristiques)
+c
+ 32 continue
+c
+ aduold = adui(nrotab)
+ ilongr = lgalli(nrotab)
+ nomtab = nomali(nrotab)
+c
+ call gmdesi ( nomtab , ilongr , detlg0)
+c
+c 3.3. ==> on le realloue (--> on detruit ainsi le trou precedant
+c qui se propage vers la droite )
+c attention, l'adresse renvoyee est l'adresse utile
+c
+ call gmaloi ( nomtab , adunew , ilongr )
+c
+c 3.4. ==> on translate son contenu de l'ancienne position a la nouvelle
+c si le tableau n'est pas de longueur nulle
+c
+ if ( ilongr.ne.0 ) then
+ call gmshfi ( imem , adunew , aduold , ilongr )
+ endif
+c
+c 3.5. ==> on recommence jusqu'a epuisement
+c
+ goto 3
+c
+ endif
+c
+#ifdef _DEBUG_HOMARD_
+ call gmdmpi ( iaux )
+#endif
+c
+c====
+c 4. traitement du tableau character*8
+c====
+c
+#ifdef _DEBUG_HOMARD_
+ call gmdmps ( iaux )
+#endif
+c
+ nrotab = 0
+c
+ 4 continue
+c
+ if ( ntrous.gt.1 ) then
+c
+ blabla = 'caractere '
+c
+c 4.1. ==> on cherche le premier tableau alloue qui suit le trou "1"
+c il suffit d'explorer a partir du dernier trouve
+c
+ iptfin = ptrous(1) + ltrous(1)
+c
+ ideb = nrotab + 1
+ do 41 , iaux = ideb , nballs
+ if ( ptalls(iaux).eq.iptfin ) then
+ nrotab = iaux
+ goto 42
+ endif
+ 41 continue
+c
+c --> pb de consistance entre les trous et les variables allouees
+c
+ write(ulsort,10000) blabla, ptrous(1), ltrous(1)
+ iaux = 3
+ call gmdmps ( iaux )
+ call ugstop ( 'gmcmpr-caractere', ulsort, 0, 1, 1 )
+c
+c 4.2. ==> on libere ce tableau (apres avoir memorise ses
+c caracteristiques)
+c
+ 42 continue
+c
+ aduold = adus(nrotab)
+ ilongr = lgalls(nrotab)
+ nomtab = nomals(nrotab)
+c
+ call gmdess ( nomtab , ilongr , detlg0)
+c
+c 4.3. ==> on le realloue (--> on detruit ainsi le trou precedant
+c qui se propage vers la droite )
+c attention, l'adresse renvoyee est l'adresse utile
+c
+ call gmalos ( nomtab , adunew , ilongr )
+c
+c 4.4. ==> on translate son contenu de l'ancienne position a la nouvelle
+c si le tableau n'est pas de longueur nulle
+c
+ if ( ilongr.ne.0 ) then
+ call gmshfs ( smem , adunew , aduold , ilongr )
+ endif
+c
+c 4.5. ==> on recommence jusqu'a epuisement
+c
+ goto 4
+c
+ endif
+c
+#ifdef _DEBUG_HOMARD_
+ call gmdmps ( iaux )
+#endif
+c
+c====
+c 5. fin du travail
+c====
+c
+ minler = min(minler,minmer)
+ if ( ntrour.ne.0 ) then
+ minmer = ltrour(1)
+ if ( nballr.ne.0 ) then
+ nommxr = nomalr(nballr)
+ endif
+ endif
+c
+ minlei = min(minlei,minmei)
+ if ( ntroui.ne.0 ) then
+ minmei = ltroui(1)
+ if ( nballi.ne.0 ) then
+ nommxi = nomali(nballi)
+ endif
+ endif
+c
+ minles = min(minles,minmes)
+ if ( ntrous.ne.0 ) then
+ minmes = ltrous(1)
+ if ( nballs.ne.0 ) then
+ nommxs = nomals(nballs)
+ endif
+ endif
+c
+c lindef est remis a 0 pour permettre de nouveau l'initialisation
+c
+ lindef = 0
+c
+ codret = 0
+c
+ endif
+c
+ end
