src/tool/Gestion_MTU/gmcmpr.F

   1       subroutine gmcmpr ( codret )
   2 c ______________________________________________________________________
   3 c
   4 c                             H O M A R D
   5 c
   6 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   7 c
   8 c Version originale enregistree le 18 juin 1996 sous le numero 96036
   9 c aupres des huissiers de justice Simart et Lavoir a Clamart
  10 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  11 c aupres des huissiers de justice
  12 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  13 c
  14 c    HOMARD est une marque deposee d'Electricite de France
  15 c
  16 c Copyright EDF 1996
  17 c Copyright EDF 1998
  18 c Copyright EDF 2002
  19 c Copyright EDF 2020
  20 c ______________________________________________________________________
  21 c
  22 c  - interet:
  23 c    . Aucun en mode dynamique de gestion de la memoire !!!!!
  24 c    . En mode statique, on elimine les trous laisses entre les
  25 c      differents tableaux entiers, reels et character*8
  26 c      de maniere a offrir le maximum de place disponible en un seul
  27 c      trou situe en fin des tableaux de travail.
  28 c      attention la reallocation se fait sans reinitialiser la memoire
  29 c      en mettant lindef a 1. lindef est remis a 0 en fin de programme.
  30 c
  31 c      La technique est la suivante :
  32 c      Tant qu'il reste au moins deux trous (en effet, s'il n'en reste
  33 c      qu'un, il est forcement a la fin, donc c'est gagne !) :
  34 c      a. recherche du premier tableau qui suit le premier trou.
  35 c      b. memorisation de son nom, son adresse utile, sa longueur
  36 c      c. retrait de ses references des tables de GM
  37 c      d. allocation d'un tableau de meme nom et de meme longueur : GM
  38 c         va forcement le placer au debut du premier trou et creer
  39 c         un trou a sa suite
  40 c      e. si le tableau n'est pas de longueur nulle, decalage du contenu
  41 c
  42 c    - restriction d'utilisation
  43 c      apres cet appel, il faut prendre soin de rechercher
  44 c      les nouveaux pointeurs des tableaux toujours en usage par appel
  45 c      a gmadoj
  46 c
  47 c ______________________________________________________________________
  48 c .        .     .        .                                            .
  49 c .  nom   . e/s . taille .           description                      .
  50 c .____________________________________________________________________.
  51 c . codret .  s  . ent    . code retour de l'operation                 .
  52 c .        .     .        .  0 : OK                                    .
  53 c .        .     .        .  2 : probleme                              .
  54 c ______________________________________________________________________
  55 c
  56 c====
  57 c 0. declarations et dimensionnement
  58 c====
  59 c
  60 c 0.1. ==> generalites
  61 c
  62       implicit none
  63       save
  64 c
  65 #include "gmmaxt.h"
  66 c
  67 c 0.2. ==> communs
  68 c
  69 #include "gmtyge.h"
  70 c
  71 #include "gmenti.h"
  72 #include "gmreel.h"
  73 #include "gmstri.h"
  74 c
  75 #include "gmtrrl.h"
  76 #include "gmtren.h"
  77 #include "gmtrst.h"
  78 c
  79 #include "gmalrl.h"
  80 #include "gmalen.h"
  81 #include "gmalst.h"
  82 c
  83 #include "gmadui.h"
  84 #include "gmadur.h"
  85 #include "gmadus.h"
  86 c
  87 #include "gmimpr.h"
  88 c
  89 #include "gmindf.h"
  90 c
  91 c 0.3. ==> arguments
  92 c
  93       integer codret
  94 c
  95 c 0.4. ==> variables locales
  96 c
  97       character*8 nomtab
  98       character*16 blabla
  99 c
 100       integer aduold, ilongr, adunew, iptfin
 101       integer iaux, ideb, nrotab
 102 c
 103       logical detlg0
 104 c
 105 c 0.5. ==> initialisations
 106 c
 107       detlg0 = .true.
 108 c ______________________________________________________________________
 109 c
 110 #ifdef _DEBUG_HOMARD_
 111       write(ulsort,*) 'Compression de la memoire'
 112 #endif
 113 c
 114 #include "impr03.h"
 115 c
 116 c====
 117 c 1. Pas de compression en mode dynamique
 118 c====
 119 c
 120       if ( modgm.eq.2) then
 121 c
 122         codret = 0
 123 #ifdef _DEBUG_HOMARD_
 124         write(ulsort,*) 'impossible en mode dynamique'
 125 #endif
 126 c
 127       else
 128 c
 129       lindef = 1
 130 c
 131 10000 format (//2x,' =======  spg gmcmpr  ==========',/2x,
 132      >       'Zone en ',a16,/2x,
 133      >       'le trou debutant en ',i4,' et de longueur ',i4,/2x,
 134      > 'n''est pas contigu a un tableau entier alloue --> probleme')
 135 c
 136 c====
 137 c 2. traitement du tableau reel
 138 c====
 139 c
 140 #ifdef _DEBUG_HOMARD_
 141       call gmdmpr ( iaux )
 142 #endif
 143 c
 144       nrotab = 0
 145 c
 146     2 continue
 147 c
 148       if ( ntrour.gt.1 ) then
 149 c
 150         blabla = 'reel            '
 151 c
 152 c 2.1. ==> on cherche le premier tableau alloue qui suit le trou "1"
 153 c          il suffit d'explorer a partir du dernier trouve
 154 c
 155         iptfin = ptrour(1) + ltrour(1)
 156 c
 157         ideb = nrotab + 1
 158         do 21 , iaux = ideb , nballr
 159            if ( ptallr(iaux).eq.iptfin ) then
 160             nrotab = iaux
 161             goto 22
 162           endif
 163    21   continue
 164 c
 165 c --> pb de consistance entre les trous et les variables allouees
 166 c
 167         write(ulsort,10000) blabla, ptrour(1), ltrour(1)
 168         iaux = 3
 169         call gmdmpr ( iaux )
 170         call ugstop ( 'gmcmpr-reel', ulsort, 0, 1, 1 )
 171 c
 172 c 2.2. ==> on libere ce tableau (apres avoir memorise ses
 173 c          caracteristiques)
 174 c
 175    22   continue
 176 c
 177         aduold = adur(nrotab)
 178         ilongr = lgallr(nrotab)
 179         nomtab = nomalr(nrotab)
 180 c
 181         call gmdesr ( nomtab , ilongr , detlg0)
 182 c
 183 c 2.3. ==> on le realloue (--> on detruit ainsi le trou precedant
 184 c          qui se propage vers la droite )
 185 c          attention, l'adresse renvoyee est l'adresse utile
 186 c
 187         call gmalor ( nomtab , adunew , ilongr )
 188 c
 189 c 2.4. ==> on translate son contenu de l'ancienne position a la nouvelle
 190 c          si le tableau n'est pas de longueur nulle
 191 c
 192         if ( ilongr.ne.0 ) then
 193           call gmshfr ( rmem , adunew , aduold , ilongr )
 194         endif
 195 c
 196 c 2.5. ==> on recommence jusqu'a epuisement
 197 c
 198         goto 2
 199 c
 200       endif
 201 c
 202 #ifdef _DEBUG_HOMARD_
 203       call gmdmpr ( iaux )
 204 #endif
 205 c
 206 c====
 207 c 3. traitement du tableau entier
 208 c    on n'effectue un passage que s'il existe plusieurs trous dans
 209 c    le tableau, car quand il n'y en a qu'un, il est au bout.
 210 c====
 211 c
 212 #ifdef _DEBUG_HOMARD_
 213       call gmdmpi ( iaux )
 214 #endif
 215 c
 216       nrotab = 0
 217 c
 218   3   continue
 219 c
 220       if ( ntroui.gt.1 ) then
 221 c
 222         blabla = 'entier          '
 223 c
 224 c 3.1. ==> on cherche le premier tableau alloue qui suit le trou "1"
 225 c          il suffit d'explorer a partir du dernier trouve
 226 c
 227         iptfin = ptroui(1) + ltroui(1)
 228 c
 229         ideb = nrotab + 1
 230         do 31 , iaux = ideb , nballi
 231           if ( ptalli(iaux).eq.iptfin ) then
 232             nrotab = iaux
 233             goto 32
 234           endif
 235    31   continue
 236 c
 237 c --> pb de consistance entre les trous et les variables allouees
 238 c
 239         write(ulsort,10000) blabla, ptroui(1), ltroui(1)
 240         iaux = 3
 241         call gmdmpi ( iaux )
 242         call ugstop ( 'gmcmpr_entier', ulsort, 0, 1, 1 )
 243 c
 244 c 3.2. ==> on libere ce tableau (apres avoir memorise ses
 245 c          caracteristiques)
 246 c
 247    32   continue
 248 c
 249         aduold = adui(nrotab)
 250         ilongr = lgalli(nrotab)
 251         nomtab = nomali(nrotab)
 252 c
 253         call gmdesi ( nomtab , ilongr , detlg0)
 254 c
 255 c 3.3. ==> on le realloue (--> on detruit ainsi le trou precedant
 256 c          qui se propage vers la droite )
 257 c          attention, l'adresse renvoyee est l'adresse utile
 258 c
 259         call gmaloi ( nomtab , adunew , ilongr )
 260 c
 261 c 3.4. ==> on translate son contenu de l'ancienne position a la nouvelle
 262 c          si le tableau n'est pas de longueur nulle
 263 c
 264         if ( ilongr.ne.0 ) then
 265           call gmshfi ( imem , adunew , aduold , ilongr )
 266         endif
 267 c
 268 c 3.5. ==> on recommence jusqu'a epuisement
 269 c
 270         goto 3
 271 c
 272       endif
 273 c
 274 #ifdef _DEBUG_HOMARD_
 275       call gmdmpi ( iaux )
 276 #endif
 277 c
 278 c====
 279 c 4. traitement du tableau character*8
 280 c====
 281 c
 282 #ifdef _DEBUG_HOMARD_
 283       call gmdmps ( iaux )
 284 #endif
 285 c
 286       nrotab = 0
 287 c
 288   4   continue
 289 c
 290       if ( ntrous.gt.1 ) then
 291 c
 292         blabla = 'caractere       '
 293 c
 294 c 4.1. ==> on cherche le premier tableau alloue qui suit le trou "1"
 295 c          il suffit d'explorer a partir du dernier trouve
 296 c
 297         iptfin = ptrous(1) + ltrous(1)
 298 c
 299         ideb = nrotab + 1
 300         do 41 , iaux = ideb , nballs
 301            if ( ptalls(iaux).eq.iptfin ) then
 302             nrotab = iaux
 303             goto 42
 304           endif
 305    41   continue
 306 c
 307 c --> pb de consistance entre les trous et les variables allouees
 308 c
 309         write(ulsort,10000) blabla, ptrous(1), ltrous(1)
 310         iaux = 3
 311         call gmdmps ( iaux )
 312         call ugstop ( 'gmcmpr-caractere', ulsort, 0, 1, 1 )
 313 c
 314 c 4.2. ==> on libere ce tableau (apres avoir memorise ses
 315 c          caracteristiques)
 316 c
 317    42   continue
 318 c
 319         aduold = adus(nrotab)
 320         ilongr = lgalls(nrotab)
 321         nomtab = nomals(nrotab)
 322 c
 323         call gmdess ( nomtab , ilongr , detlg0)
 324 c
 325 c 4.3. ==> on le realloue (--> on detruit ainsi le trou precedant
 326 c          qui se propage vers la droite )
 327 c          attention, l'adresse renvoyee est l'adresse utile
 328 c
 329         call gmalos ( nomtab , adunew , ilongr )
 330 c
 331 c 4.4. ==> on translate son contenu de l'ancienne position a la nouvelle
 332 c          si le tableau n'est pas de longueur nulle
 333 c
 334         if ( ilongr.ne.0 ) then
 335           call gmshfs ( smem , adunew , aduold , ilongr )
 336         endif
 337 c
 338 c 4.5. ==> on recommence jusqu'a epuisement
 339 c
 340         goto 4
 341 c
 342       endif
 343 c
 344 #ifdef _DEBUG_HOMARD_
 345       call gmdmps ( iaux )
 346 #endif
 347 c
 348 c====
 349 c 5. fin du travail
 350 c====
 351 c
 352       minler = min(minler,minmer)
 353       if ( ntrour.ne.0 ) then
 354         minmer = ltrour(1)
 355         if ( nballr.ne.0 ) then
 356           nommxr = nomalr(nballr)
 357         endif
 358       endif
 359 c
 360       minlei = min(minlei,minmei)
 361       if ( ntroui.ne.0 ) then
 362         minmei = ltroui(1)
 363         if ( nballi.ne.0 ) then
 364           nommxi = nomali(nballi)
 365         endif
 366       endif
 367 c
 368       minles = min(minles,minmes)
 369       if ( ntrous.ne.0 ) then
 370         minmes = ltrous(1)
 371         if ( nballs.ne.0 ) then
 372           nommxs = nomals(nballs)
 373         endif
 374       endif
 375 c
 376 c lindef est remis a 0 pour permettre de nouveau l'initialisation
 377 c
 378       lindef = 0
 379 c
 380       codret = 0
 381 c
 382       endif
 383 c
 384       end