src/tool/Gestion_MTU/gmmodg.F

   1       subroutine gmmodg ( nomtab, lgold, lgnew,
   2      >                    d1old,  d1new,   d2old,  d2new,
   3      >                    adunew,  aduold,  type8,
   4      >                    minmeg, ntroug, nballg, totalg,
   5      >                    ptroug, ltroug, ptallg, lgallg, adug,
   6      >                    nommxg, nomalg, tablte )
   7 c ______________________________________________________________________
   8 c
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c ......................................................................
  27 c .           auteur : gn 09/93
  28 c ......................................................................
  29 c .
  30 c .  - interet:
  31 c  . si les tailles sont toutes positives :
  32 c          on passe de tab(d1old,d2old) a tab(d1new,d2new)
  33 c  . si les tailles d1x sont negatives et les tailles d2x positives :
  34 c          on passe de tab(d1old:d2old) a tab(d1new:d2new)
  35 c  . sinon : probleme ...
  36 c .   remarque : on peut aussi bien etendre que raccourcir
  37 c .   remarque : ceci marche meme si une des dimensions reste egale
  38 c .              a 1 mais ce n'est pas optimal ; il vaut mieux utiliser
  39 c .              le programme prevu pour les monodimensionnels, gmextg
  40 c .
  41 c .  - realisation:
  42 c .       reallocation, recopie des donnees,
  43 c .       suppression de l'original, reaffectation du nom original
  44 c .
  45 c .  - arguments:
  46 c . donnees nomtab  --> nom du tableau concerne (8 caracteres maxi)
  47 c .         lgold   --> longueur avant
  48 c .         lgnew   --> longueur apres
  49 c .         d1old   --> premiere dimension avant
  50 c .         d1new   --> premiere dimension apres
  51 c .         d2old   --> seconde dimension avant
  52 c .         d2new   --> seconde dimension apres
  53 c .         type8   --> type du tableau :r,i,s,d
  54 c .modifies minmeg <--> valeur entiere memorisant la plus petite
  55 c .                     dimension du dernier trou afin de connaitre
  56 c .                     le passage le plus delicat rencontre au cours
  57 c .                     de l'allocation. cette valeur est calculee
  58 c .                     apres compression
  59 c .         ntroug <--> valeur entiere . nombre de trous present
  60 c .         nballg <--> nombre de tableaux deja alloues
  61 c .         totalg <--> valeur entiere cumulant les demandes
  62 c .                     successives de memoire
  63 c .         ptroug <--> tableau entier contenant les pointeurs
  64 c .                     repertoriant la position des trous
  65 c .         ltroug <--> tableau entier contenant la longueur des trous
  66 c .         ptallg <--> tableau entier contenant les pointeurs
  67 c .                     repertoriant la position des tableaux
  68 c .         adug   <--> adresses utiles des tableaux (retour de gbcara)
  69 c .         lgallg <--> tableau entier contenant la longueur des
  70 c .                     tableaux
  71 c .         nommxg <--> chaine de caractere(*8) contenant le nom du
  72 c .                     plus grand tableau associe a minmeg
  73 c .         nomalg <--> tableau de chaines de caracteres contenant
  74 c .                     le nom associe a chaque tableau deja alloue
  75 c .resultat adunew <--  pointeur associe apres extension
  76 c .         aduold <--  pointeur avant extension
  77 c .         tablte <--  nom du tableau temporaire
  78 c .
  79 c ......................................................................
  80 c .
  81 c .
  82 c====
  83 c 0. declarations et dimensionnement
  84 c====
  85 c
  86 c 0.1. ==> generalites
  87 c
  88       implicit none
  89       save
  90 c
  91       character*6 nompro
  92       parameter ( nompro = 'GMMODG' )
  93 c
  94 #include "genbla.h"
  95 #include "gmmaxt.h"
  96 c
  97 c 0.2. ==> communs
  98 c
  99 #include "gmtail.h"
 100 #include "gmtyge.h"
 101 c
 102 #include "gmimpr.h"
 103 #include "envex1.h"
 104 #include "gmlang.h"
 105 #include "gmcoer.h"
 106 c
 107 c 0.3. ==> arguments
 108 c
 109       integer lgold, lgnew
 110       integer d1old, d1new, d2old, d2new
 111       integer adug(maxtab)
 112 c
 113       integer adunew, aduold
 114       integer minmeg, ntroug, nballg, totalg
 115       integer ptroug(maxtrs) , ltroug(maxtrs)
 116       integer ptallg(maxtab) , lgallg(maxtab)
 117 c
 118       character*(*) nomtab
 119       character*1 type8
 120       character*8 nommxg, nomalg(maxtab)
 121       character*8 tablte
 122 c
 123 c 0.4. ==> variables locales
 124 c
 125       character*8 nomvar
 126 c
 127       integer iaux
 128       integer i, icptg, iold
 129       integer iptold
 130       integer ltype, ad0, ad1
 131       integer nbcain
 132 c
 133       character*6 nompra
 134 c
 135       character*1 carint(1)
 136 c
 137       integer nbmess
 138       parameter ( nbmess = 10 )
 139       character*80 texte(nblang,nbmess)
 140
 141 c====
 142 c 1. initialisations
 143 c====
 144 c
 145 #include "impr01.h"
 146 c
 147 #ifdef _DEBUG_HOMARD_
 148       write (ulsort,texte(langue,1)) 'Entree', nompro
 149       call dmflsh (iaux)
 150 #endif
 151 c
 152 c====
 153 c 1. preliminaires
 154 c====
 155 c
 156       coergm = 0
 157 c
 158       if ( type8.eq.'i' .or. type8.eq.'I' ) then
 159          ltype = tentie
 160          ad0 = adcom(1)
 161          ad1 = admem(1)
 162          nompra = 'GMMODI'
 163       elseif ( type8.eq.'r' .or. type8.eq.'R' ) then
 164          nompra = 'GMMODR'
 165          ltype = treel
 166          ad0 = adcom(2)
 167          ad1 = admem(2)
 168       elseif ( type8.eq.'s' .or. type8.eq.'S' ) then
 169          ltype = tchain
 170          ad0 = adcom(3)
 171          ad1 = admem(3)
 172          nompra = 'GMMODS'
 173       else
 174          write(ulsort,20000) nompro, type8
 175          coergm = 5
 176       endif
 177 c
 178 20000 format (//2x,' ******  spg ',a6,'  *****',
 179      >        /2x,'Le type ',a1,' est inconnu.',
 180      >        /2x,'Il faut r, i ou s',
 181      >        /2x,'    ===>  arret dans le gestionnaire de memoire')
 182 c
 183 c====
 184 c  2. verifications
 185 c====
 186 c
 187 c 2.1. ==> nature du nom
 188 c          aucun caractere n'est interdit, mais on met un blanc
 189 c          dans le tableau pour ne plus avoir de messages ftnchek
 190 c
 191       if ( coergm.eq.0 ) then
 192 c
 193       nbcain = 0
 194       carint(1) = ' '
 195       call gmntve ( nomtab, nomvar, nbcain, carint, coergm )
 196 c
 197       if ( coergm.ne.0 ) then
 198          write(ulsort,21100) nompro, nompra
 199 21100    format ( 2x,'Probleme a l''appel au spg ',a6,' via ',a6,
 200      >          /,4x,'    ===>  arret dans le gestionnaire de memoire')
 201         coergm = 6
 202       endif
 203 c
 204       endif
 205 c
 206       if ( coergm.eq.0 ) then
 207 c
 208 c--- verif que le nom n'est utilise qu'une fois et une seule
 209 c
 210       icptg = 0
 211       do 22  i = 1 , nballg
 212         if ( nomalg(i).eq.nomvar ) then
 213           iold = i
 214           icptg = icptg + 1
 215         endif
 216    22 continue
 217 c
 218       if ( icptg.eq.0 ) then
 219         write(ulsort,20003) nompro, nompra, nomvar
 220 20003   format ( 2x,'Probleme a l''appel au spg ',a6,' via ',a6,
 221      >         /,4x,'Le tableau (',a8,') n''a pas ete alloue',
 222      >         /,4x,'    ===>  arret dans le gestionnaire de memoire')
 223         call ugstop( nompro,ulsort,0,1,1)
 224       elseif (icptg.gt.1) then
 225         write(ulsort,20013) nompro, nompra, nomvar
 226 20013   format ( 2x,'Probleme a l''appel au spg ',a6,' via ',a6,
 227      >         /,4x,'Le tableau (',a8,') a ete alloue plusieurs fois' ,
 228      >         /,4x,'    ===>  arret dans le gestionnaire de memoire')
 229         call ugstop( nompro,ulsort,0,1,1)
 230       endif
 231 c
 232       endif
 233 c
 234 c====
 235 c  3. traitement
 236 c====
 237 c
 238       if ( coergm.eq.0 ) then
 239 c
 240 c---- verif que l'ancienne taille correspond bien aux dimensions
 241 c     annoncees
 242 c
 243       if ( lgallg(iold).ne.lgold ) then
 244         write(ulsort,30001) nompro, nompra, nomvar
 245         if ( d1old.gt.0 ) then
 246           write(ulsort,30002) d1old, d2old, lgold
 247         else
 248           write(ulsort,30003) -d1old, d2old, lgold
 249         endif
 250         write(ulsort,30004) lgallg(iold), d1old, d2old, d1new, d2new
 251 30001   format ( 2x,'Probleme a l''appel au spg ',a6,' via ',a6,
 252      >         /,4x,' pour le tableau ',a)
 253 30002   format (
 254      > 4x,'L''ancienne taille annoncee ',i10,' x ',i10,' = ',i10)
 255 30003   format (
 256      > 4x,'L''ancienne taille annoncee ',i10,' + ',i10,' = ',i10)
 257 30004   format ( 4x,'ne correspond pas a la longueur en memoire ',i10,
 258      >         /,4x,'Pour memoire, on veut passer de ',
 259      >         /,4x,'(',i10,' ,',i10,' ) a (',i10,' ,',i10,' )',
 260      >         /,4x,'    ===>  arret dans le gestionnaire de memoire')
 261         call ugstop( nompro,ulsort,0,1,1)
 262       endif
 263 c
 264       iptold = ptallg(iold)
 265 c
 266       if ( modgm.eq.2 ) then
 267 c
 268 c mode dynamique :
 269 c
 270         aduold = (iptold-ad0)/ltype
 271 c
 272 c en particulier pour les "gros types",
 273 c on n'a pas vraiment de garantie que la division precedente
 274 c "tombe juste". Le fait d'avoir en fait alloue un peu plus grand
 275 c (cf. appel a gbalme dans gmalog) permet de se mettre a l'abris
 276 c de ce genre de probleme (entre autres).
 277 c
 278         if ( aduold*ltype .ge. iptold-ad0 ) then
 279           aduold = aduold + 1
 280         else
 281           aduold = aduold + 2
 282         endif
 283 c
 284       else if ( modgm.eq.1 ) then
 285         aduold = ((ad1-ad0)/ltype) + iptold + 1
 286       else
 287         aduold = ((ad1-ad0)/ltype) + iptold
 288       endif
 289 c
 290 c---- en mode non dynamique, s'il n'y a plus de trou : erreur
 291 c
 292       if ( modgm.ne.2 ) then
 293 c
 294         if (ntroug.eq.0) then
 295           write(ulsort,30005) nompro, nompra, nomvar
 296 30005     format ( 2x,'Probleme a l''appel au spg ',a6,' via ',a6,
 297      >           /,4x,' pour le tableau ',a8,
 298      >           /,4x,'Il n''y a plus de place')
 299           call ugstop( nompro,ulsort,0,1,1)
 300         endif
 301 c
 302       endif
 303 c
 304       endif
 305 c
 306 c----
 307 c 4. contrairement au cas monodimensionnel,
 308 c    on est oblige de creer un tableau different
 309 c    ailleurs car le rangement est tel que les memes valeurs ne sont
 310 c    plus a la meme place
 311 c    ex a(1,1)=1    a(1,2)=2    a(1,3)=3
 312 c       a(2,1)=4    a(2,2)=5    a(2,3)=6
 313 c    le tableau a(2x3) est range ainsi : 1 4 2 5 3 6
 314 c    s'il devient un tableau a(3x3), les anciennes valeurs seront
 315 c    mises ainsi : 1 4 x 2 5 x 3 6 x
 316 c----
 317 c
 318       if ( coergm.eq.0 ) then
 319 c
 320       call gbntcr ( tablte )
 321       call gmalog ( tablte, adunew,  lgnew, type8,
 322      >         minmeg, ntroug, nballg, totalg,
 323      >         ptroug, ltroug, ptallg, lgallg,adug,
 324      >         nommxg, nomalg )
 325 c
 326       endif
 327 c
 328       if ( coergm.ne.0 ) then
 329 c
 330 #include "envex2.h"
 331 c
 332       endif
 333 c
 334       end