X-Git-Url: http://git.salome-platform.org/gitweb/?a=blobdiff_plain;f=src%2Ftool%2FGestion_MTU%2Fgmcmpr.F;fp=src%2Ftool%2FGestion_MTU%2Fgmcmpr.F;h=f96fbfa02838a2c77f6a4ed3682690766f43ce82;hb=3e48edf702d97267d52647274bbaf2b05a6f6050;hp=0000000000000000000000000000000000000000;hpb=739517435bbd756426c0f0decff89875ea8fb0dc;p=modules%2Fhomard.git

diff --git a/src/tool/Gestion_MTU/gmcmpr.F b/src/tool/Gestion_MTU/gmcmpr.F
new file mode 100644
index 00000000..f96fbfa0
--- /dev/null
+++ b/src/tool/Gestion_MTU/gmcmpr.F
@@ -0,0 +1,384 @@
+      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