src/tool/Gestion_MTU/gmdesg.F

   1       subroutine gmdesg ( nomtab, nbplac,   type1, detlg0,
   2      >                    ntroug, nballg, ptroug, ltroug,
   3      >                    ptallg, lgallg,   adug, nomalg )
   4 c ______________________________________________________________________
   5 c
   6 c                             H O M A R D
   7 c
   8 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   9 c
  10 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  11 c aupres des huissiers de justice Simart et Lavoir a Clamart
  12 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  13 c aupres des huissiers de justice
  14 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  15 c
  16 c    HOMARD est une marque deposee d'Electricite de France
  17 c
  18 c Copyright EDF 1996
  19 c Copyright EDF 1998
  20 c Copyright EDF 2002
  21 c Copyright EDF 2020
  22 c ______________________________________________________________________
  23 c ......................................................................
  24 c . creation octobre 93 gn
  25 c ......................................................................
  26 c
  27 c le programme libere nbplac mots de memoire a partir de la fin
  28 c pour le tableau nomtab                     ==================
  29 c
  30 c ......................................................................
  31 c .
  32 c .  - fonction :
  33 c .   programme generique de desallocation d'un emplacement memoire
  34 c . 'attention' le contenu du tableau est inchange
  35 c .
  36 c .  - realisation:
  37 c .       recherche du premier trou memoire suivant
  38 c .       mise a jour du tableau des trous (rallonge ou creation)
  39 c .       mise a jour des tableaux des variables allouees (stats)
  40 c .
  41 c .  - arguments:
  42 c . donnees nomtab  --> nom du tableau concerne
  43 c .         nbplac  --> nombre de mots liberes a partir de la fin
  44 c .         type1   --> type du tableau :r,i,s,d, ou c
  45 c .         detlg0  --> vrai/faux pour la destruction du tableau s'il
  46 c .                     devient de longueur nulle
  47 c .modifies ntroug <--> valeur entiere . nombre de trous presents
  48 c .         nballg <--> nombre de tableaux deja alloues
  49 c .         ptroug <--> tableau entier contenant les pointeurs
  50 c .                     repertoriant la position des trous
  51 c .         ltroug <--> tableau entier contenant la longueur des trous
  52 c .         ptallg <--> tableau entier contenant les pointeurs
  53 c .                     repertoriant la position des tableaux
  54 c .         adug   <--> adresses utiles des tableaux
  55 c .                     telles que retournees par gbcara
  56 c .         lgallg <--> tableau entier contenant la longueur des
  57 c .                     tableaux
  58 c .         nomalg <--> tableau de chaines de caracteres contenant
  59 c .                     le nom associe a chaque tableau deja alloue
  60 c .  - restriction d' usage
  61 c .      le spg n'accepte de desallouer la zone prescrite que si celle
  62 c .      ci est integralement contenue dans un tableau effectivement
  63 c .      alloue precedemment. cela autorise une desallocation partielle.
  64 c .      il ne desalloue jamais un tableau de longueur nulle. en effet
  65 c .      meme si pointe coincide avec l'adresse d'un tableau de longueur
  66 c .      nulle il n'est pas possible de savoir si l'on a voulu
  67 c .      desallouer la fin du tableau precedent mais il se trouve que
  68 c .      nbplac est nul ou le tableau de longueur nulle qui se trouve a
  69 c .      l'adresse pointe
  70 c .
  71 c ......................................................................
  72 c .
  73 c====
  74 c 0. declarations et dimensionnement
  75 c====
  76 c
  77 c 0.1. ==> generalites
  78 c
  79       implicit none
  80       save
  81 c
  82       character*6 nompro
  83       parameter ( nompro = 'GMDESG' )
  84 c
  85 #include "genbla.h"
  86 #include "gmmaxt.h"
  87 c
  88 c 0.2. ==> communs
  89 c
  90 #include "gmtail.h"
  91 #include "gmtyge.h"
  92 c
  93 #include "gmindi.h"
  94 #include "gminds.h"
  95 c
  96 #include "gmtrrl.h"
  97 #include "gmtren.h"
  98 #include "gmtrst.h"
  99 c
 100 #include "gmimpr.h"
 101 #include "envex1.h"
 102 #include "gmlang.h"
 103 #include "gmcoer.h"
 104 c
 105 c 0.3. ==> arguments
 106 c
 107       character*1 type1
 108       character*8 nomtab, nomalg(maxtab)
 109 c
 110       integer nbplac, ntroug, nballg
 111       integer ptroug(maxtrs) , ltroug(maxtrs)
 112       integer ptallg(maxtab) , lgallg(maxtab)
 113       integer adug(maxtab)
 114 c
 115       logical detlg0
 116 c
 117 c 0.4. ==> variables locales
 118 c
 119       integer adut
 120 c
 121       integer ltype
 122 c     decal : decalage / au debut de la zone
 123 c             uniquement en mode statique ou semi-dynamique
 124 c
 125       integer decal
 126 c
 127 c     adabs : adressr absolue
 128 c
 129       integer adabs, ad0
 130 c
 131       character*8 typobs
 132 c
 133       integer iaux, jaux, nrotab, nrotro
 134 c
 135       character*6 nompra
 136 c
 137       logical jointb, jointh
 138 c
 139 c 0.5. ==> initialisations
 140 c ______________________________________________________________________
 141 c
 142       integer nbmess
 143       parameter ( nbmess = 10 )
 144       character*80 texte(nblang,nbmess)
 145 c
 146 c====
 147 c 1. initialisations
 148 c====
 149 c
 150 #include "impr01.h"
 151 c
 152 #ifdef _DEBUG_HOMARD_
 153       write (ulsort,texte(langue,1)) 'Entree', nompro
 154       call dmflsh (iaux)
 155 #endif
 156 c
 157 c====
 158 c  1. preliminaires
 159 c====
 160 c
 161       coergm = 0
 162 c
 163       if ( type1.eq.'i' .or. type1.eq.'I' ) then
 164         nompra = 'GMDESI'
 165         ltype = tentie
 166         ad0 = adcom(1)
 167       elseif ( type1.eq.'r' .or. type1.eq.'R' ) then
 168         nompra = 'GMDESR'
 169         ltype = treel
 170         ad0 = adcom(2)
 171       elseif ( type1.eq.'s' .or. type1.eq.'S' ) then
 172         nompra = 'GMDESS'
 173         ltype = tchain
 174         ad0 = adcom(3)
 175       else
 176         write(ulsort,10000) type1
 177         coergm = 1
 178       endif
 179 c
 180 10000 format(/2x,'Le type ',a1,' est inconnu.',
 181      >       /2x,'Il faut r, i ou s')
 182 c
 183 c====
 184 c  2. verifications
 185 c====
 186 c
 187       if ( coergm.eq.0 ) then
 188 c
 189         if ( nbplac .lt. 0 ) then
 190           write(ulsort,20001) nbplac
 191           coergm = 1
 192         endif
 193 c
 194       endif
 195 c
 196 20001 format(/2x,'On demande a liberer ',i8,' places.')
 197 c
 198 c====
 199 c 3. recherche du tableau
 200 c====
 201 c
 202       if ( coergm.eq.0 ) then
 203 c
 204 c 3.1.1. ==> recherche du numero du tableau concerne
 205 c
 206         call gbcara ( nomtab , nrotab, adut , iaux , typobs )
 207 c
 208 c 3.1.2. ==> il ne faut pas enlever plus de places qu'il n'y en a deja
 209 c
 210         if ( coergm.eq.0 ) then
 211           if ( nbplac.gt.lgallg(nrotab) ) then
 212             write(ulsort,20001) nbplac
 213             write(ulsort,30001) lgallg(nrotab)
 214             coergm = 1
 215           endif
 216         endif
 217 c
 218 30001  format(2x,'Or le tableau est alloue avec ',i8,' places.')
 219 c
 220 c 3.1.3. ==> si c'est bon, on repere les adresses de la zone a liberer
 221 c            si aucun tableau trouve --> messages d'erreur et arret
 222 c
 223         if ( coergm.eq.0 ) then
 224           if ( modgm.le.1 ) then
 225             decal = ptallg(nrotab) + lgallg(nrotab) - nbplac
 226           else
 227             adabs = ptallg(nrotab)
 228           endif
 229         endif
 230 c
 231       endif
 232 c
 233 c====
 234 c 4. en mode statique ou semi-dynamique, il faut gerer les trous
 235 c    quand on desalloue un nombre non nul de places
 236 c====
 237 c
 238       if ( coergm.eq.0 .and. modgm.le.1 .and. nbplac.ne.0 ) then
 239 c
 240 c 4.1. ==> localisation de l'adresse donnee par rapport aux trous
 241 c
 242         nrotro = 0
 243         do 41 iaux = 1, ntroug
 244           if ( ptroug(iaux).gt.decal ) then
 245             nrotro = iaux
 246             go to 42
 247           endif
 248    41   continue
 249 c
 250 c 4.2. ==> gestion du nouveau trou
 251 c
 252    42   continue
 253 c
 254         if ( nrotro.eq.0 ) then
 255 c
 256 c 4.2.1. ==> la zone liberee se situe apres tous les trous existants
 257 c              --> cela constitue un nouveau trou en fin de tableau
 258 c
 259           ntroug         = ntroug + 1
 260           ptroug(ntroug) = decal
 261           ltroug(ntroug) = nbplac
 262 c
 263         else
 264 c
 265 c 4.2.2. ==> on a trouve un trou qui est place apres la zone a liberer
 266 c            Si ce n'est pas le premier, y en a-t-il un autre avant ?
 267 c
 268           if ( nrotro.eq.1 ) then
 269             jointb = .false.
 270           else
 271             jointb = ((ptroug(nrotro-1)+ltroug(nrotro-1)).ge.decal)
 272           endif
 273 c
 274           jointh = ( (decal+nbplac).ge.ptroug(nrotro) )
 275 c
 276 c             ---> action suivant les 4 cas possibles
 277 c
 278           if (jointb.and.jointh) then
 279 c
 280 c       fusion par le bas et le haut (elimination d'un trou)
 281 c
 282             ltroug(nrotro-1) = ltroug(nrotro) +
 283      >                         ptroug(nrotro)-ptroug(nrotro-1)
 284             ntroug = ntroug-1
 285             do 43 iaux = nrotro, ntroug
 286               ptroug(iaux) = ptroug(iaux+1)
 287               ltroug(iaux) = ltroug(iaux+1)
 288    43       continue
 289             ptroug(ntroug+1) = iindef
 290             ltroug(ntroug+1) = iindef
 291 c
 292           else if (jointb) then
 293 c
 294 c       fusion par le bas
 295             ltroug(nrotro-1) = decal + nbplac - ptroug(nrotro-1)
 296 c
 297           else if (jointh) then
 298 c
 299 c       fusion par le haut
 300             ltroug(nrotro) = ptroug(nrotro) + ltroug(nrotro) - decal
 301             ptroug(nrotro) = decal
 302 c
 303           else
 304 c
 305 c       creation d'un nouveau trou au milieu
 306             ntroug = ntroug + 1
 307             jaux = ntroug
 308             do 44 iaux = nrotro+1, ntroug
 309               ptroug(jaux) = ptroug(jaux-1)
 310               ltroug(jaux) = ltroug(jaux-1)
 311               jaux=jaux-1
 312    44       continue
 313             ptroug(nrotro) = decal
 314             ltroug(nrotro) = nbplac
 315 c
 316           endif
 317 c
 318         endif
 319 c
 320       endif
 321 c
 322 c====
 323 c 5. raccourcissement effectif
 324 c====
 325 c
 326       if ( coergm.eq.0 ) then
 327 c
 328 c 5.1. ==> si tout est bon, on raccourcit
 329 c
 330         lgallg(nrotab) = lgallg(nrotab) - nbplac
 331 c
 332 c 5.2. ==> si la longueur finale est nulle et que l'on ne garde
 333 c          pas un tableau de longueur nulle, on desalloue totalement
 334 c
 335         if ( detlg0 .and. lgallg(nrotab).eq.0 ) then
 336 c
 337 c 5.2.1. ==>  on supprime le tableau des tables
 338 c
 339            nballg = nballg - 1
 340 c
 341            do 52 iaux = nrotab, nballg
 342              nomalg(iaux) = nomalg(iaux+1)
 343              ptallg(iaux) = ptallg(iaux+1)
 344              lgallg(iaux) = lgallg(iaux+1)
 345              adug(iaux)   = adug(iaux+1)
 346    52      continue
 347 c
 348            nomalg(nballg+1) = sindef
 349            ptallg(nballg+1) = iindef
 350            lgallg(nballg+1) = iindef
 351            adug(nballg+1)   = iindef
 352 c
 353 c 5.2.2. ==>  en mode dynamique, on libere la memoire
 354 c
 355            if ( modgm.eq.2 ) then
 356 c
 357              call gblibe( type1, nbplac, adabs, coergm )
 358 c
 359              if ( coergm.ne.0 ) then
 360                 write(ulsort,*) nompro, ' modgm 2 erreur au free'
 361              endif
 362 c
 363            endif
 364 c
 365          else if ( modgm.eq.2 .and. nbplac.gt.0 ) then
 366 c
 367 c Raccourcissement "partiel" en mode dynamique:
 368 c
 369 c (noter que ce raccourcissement partiel, ou re-allocation,
 370 c  n'est pas vital au fonctionnement de gm)
 371 c
 372 cgn           write(ulsort,*) 'appel de gbralo'
 373            call gbralo( type1, lgallg(nrotab)+1,
 374      >                  ptallg(nrotab), coergm )
 375 cgn           write(ulsort,*) 'retour de gbralo'
 376 c
 377            if ( coergm.ne.0 ) then
 378 c
 379              write(ulsort,*) nompro, ' modgm 2 erreur au realloc'
 380              ptallg(nrotab) = adabs
 381 c
 382            else if ( ptallg(nrotab).ne.adabs ) then
 383 c
 384 c cas ou l'adresse memoire du tableau a ete changee :
 385 c on recalcule l'adresse "utile" adug(nrotab)
 386 c
 387             adabs = (ptallg(nrotab)-ad0)/ltype
 388 c
 389             if ( adabs*ltype .ge. ptallg(nrotab)-ad0 ) then
 390               adug(nrotab) = adabs + 1
 391             else
 392               adug(nrotab) = adabs + 2
 393             endif
 394            endif
 395 c
 396          endif
 397 c
 398          if (coergm.eq.0 .and. modgm.eq.2 .and. nbplac.gt.0) then
 399 c
 400 c  gestion des grandeurs permettant d'obtenir des statistiques globales
 401 c  (meme en mode dynamique) :
 402 c
 403               if ( type1.eq.'r' .or. type1.eq.'R' ) then
 404                 minmer = minmer + nbplac
 405               else if ( type1.eq.'i' .or. type1.eq.'I' ) then
 406                 minmei = minmei + nbplac
 407               else if ( type1.eq.'s' .or. type1.eq.'S' ) then
 408                 minmes = minmes + nbplac
 409               endif
 410 c
 411          endif
 412 c
 413       endif
 414 c
 415 c====
 416 c 5. arret si erreur
 417 c====
 418 c
 419       if ( coergm.ne.0 ) then
 420 c
 421         write(ulsort,50000) nompro, nompra, nomtab
 422 c
 423         if ( type1.eq.'r' .or. type1.eq.'R' ) then
 424           call gmdmpr ( iaux )
 425         elseif ( type1.eq.'i' .or. type1.eq.'I' ) then
 426           call gmdmpi ( iaux )
 427         elseif ( type1.eq.'s' .or. type1.eq.'S' ) then
 428           call gmdmps ( iaux )
 429         endif
 430 c
 431         call ugstop ( nompro, ulsort, 0, 1, 1 )
 432 c
 433       endif
 434 c
 435 50000 format(/2x,' ******  spg ',a,' via ',a6,' *****',
 436      >      /2x,' probleme pour le tableau ',a8,
 437      >      /2x,' ===>  arret a cause du gestionnaire de memoire',
 438      >      /2x ,'Verifier votre appel a l''aide des infos suivantes')
 439 c
 440 c====
 441 c 3. Fin
 442 c====
 443 c
 444       if ( coergm.ne.0 ) then
 445 c
 446 #include "envex2.h"
 447 c
 448       endif
 449 c
 450       end