src/tool/Gestion_MTU/gmmodr.F

   1       subroutine gmmodr ( nomtab, typmod, lgold, lgnew,
   2      >                    point, d1old, d1new, d2old, d2new )
   3 c ______________________________________________________________________
   4 c
   5 c                             H O M A R D
   6 c
   7 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   8 c
   9 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  10 c aupres des huissiers de justice Simart et Lavoir a Clamart
  11 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  12 c aupres des huissiers de justice
  13 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  14 c
  15 c    HOMARD est une marque deposee d'Electricite de France
  16 c
  17 c Copyright EDF 1996
  18 c Copyright EDF 1998
  19 c Copyright EDF 2002
  20 c Copyright EDF 2020
  21 c ______________________________________________________________________
  22 c ......................................................................
  23 c .           auteur : gn 09/93
  24 c ......................................................................
  25 c .
  26 c . si les tailles sont toutes positives :
  27 c          on passe de tab(d1old,d2old) a tab(d1new,d2new)
  28 c . si les tailles d1x sont negatives et les tailles d2x positives :
  29 c          on passe de tab(d1old:d2old) a tab(d1new:d2new)
  30 c . sinon : probleme ...
  31 c .
  32 c .  - realisation:
  33 c .       tentative d'extension a l'extremite du tableau.
  34 c .       sinon reallocation recopie des donnees,
  35 c .       suppression de l'original, reaffectation du nom original
  36 c .
  37 c .  - arguments:
  38 c . donnees nomtab  --> nom du tableau a etendre (8 caracteres au plus)
  39 c .         typmod  --> A. tableau de type tab(d1,1), d1>=0
  40 c .           11 : d1 : allongement,          d2 : constant a 1
  41 c .           12 : d1 : raccourcissemement,   d2 : constant a 1
  42 c .                     B. tableau de type tab(1,d2), d2>=0
  43 c .           21 : d1 : constant a 1,         d2 : allongement
  44 c .           22 : d1 : constant a 1,         d2 : raccourcissemement
  45 c .                     C. tableau de type tab(d1,d2) avec d1>0 et d2>=0
  46 c .            1 : d1 : pas de particularite, d2 : de 0 a >=0
  47 c .            2 : d1 : pas de particularite, d2 : de >=0 a 0
  48 c .            5 : pas de particularites
  49 c .                     D. tableau de type tab(d1,d2) avec d1>0 et d2>0
  50 c .            3 : d1 : de 0 a >=0, d2 : pas de particularite
  51 c .            4 : d1 : de >=0 a 0, d2 : pas de particularite
  52 c .            5 : pas de particularites
  53 c .                     E. tableau de type tab(0:d2)
  54 c .           31 : d1 : constant a 0,         d2 : allongement
  55 c .           32 : d1 : constant a 0,         d2 : raccourcissemement
  56 c .                     F. tableau de type tab(d1:d2) d1<=0 et d2>=0
  57 c .           -1 : d1 : allongement,          d2 : constante
  58 c .           -2 : d1 : constante,            d2 : allongement
  59 c .           -3 : d1 : raccourcissemement,   d2 : constante
  60 c .           -4 : d1 : constante,            d2 : raccourcissemement
  61 c .           -5 : pas de particularites
  62 c .                     G. tableau de longueur nulle passant au
  63 c .                        type tab(1:d2) ou tab(d1:1)
  64 c .           41 : tab(1:d2)
  65 c .           51 : tab(d1:1)
  66 c .                     H. tableau devenant de longueur nulle
  67 c .           61 :
  68 c .         lgold   --> longueur avant
  69 c .         lgnew   --> longueur apres
  70 c .         d1old   --> premiere dimension avant
  71 c .         d1new   --> premiere dimension apres
  72 c .         d2old   --> seconde dimension avant
  73 c .         d2new   --> seconde dimension apres
  74 c .resultat  point  <--  pointeur associe
  75 c ......................................................................
  76 c
  77 c====
  78 c 0. declarations et dimensionnement
  79 c====
  80 c
  81 c 0.1. ==> generalites
  82 c
  83       implicit none
  84       save
  85 c
  86       character*6 nompro
  87       parameter ( nompro = 'GMMODR' )
  88 c
  89 #include "genbla.h"
  90 #include "gmmaxt.h"
  91 c
  92 c 0.2. ==> communs
  93 c
  94 #include "gmreel.h"
  95 #include "gmadur.h"
  96 #include "gmtrrl.h"
  97 #include "gmalrl.h"
  98 #include "gmindf.h"
  99 #include "gmindr.h"
 100 c
 101 #include "envex1.h"
 102 #include "gmcoer.h"
 103 #include "gmimpr.h"
 104 #include "gmlang.h"
 105 c
 106 c 0.3. ==> arguments
 107 c
 108       character *(*) nomtab
 109 c
 110       integer typmod, lgold, lgnew
 111       integer d1old, d1new, d2old, d2new
 112       integer point
 113 c
 114 c 0.4. ==> variables locales
 115 c
 116       integer iaux
 117       integer i, ideb, ifin, j, d1min, d2min
 118       integer kdeb, kfin, k, kaux
 119       integer iptold
 120       integer lgallo
 121 c
 122       character*8 nomvar, tablte
 123       character*1 type1
 124 c
 125       logical detlg0
 126       logical satien
 127 c
 128       integer nbmess
 129       parameter ( nbmess = 10 )
 130       character*80 texte(nblang,nbmess)
 131 c
 132 c====
 133 c 1. messages
 134 c====
 135 c
 136 #include "impr01.h"
 137 c
 138 #ifdef _DEBUG_HOMARD_
 139       write (ulsort,texte(langue,1)) 'Entree', nompro
 140       call dmflsh (iaux)
 141 #endif
 142 c
 143 #ifdef _DEBUG_HOMARD_
 144       write (ulsort,*) 'typmod =', typmod
 145 #endif
 146 c
 147       coergm = 0
 148 c
 149 c====
 150 c  2. verifications initiales
 151 c====
 152 c
 153       call gmcata ( nomtab, lgallo,
 154      >              nballr, nomalr, lgallr )
 155 c
 156       if ( lgallo.ne.lgold ) then
 157         write(ulsort,20000) nompro, nomtab, lgallo, lgold
 158 20000   format ( 2x,'Probleme dans ',a6,' pour le tableau ',a,
 159      >         /,4x,'. Longueur d''allocation : ',i10 ,
 160      >         /,4x,'. Longueur ''ancienne''   : ',i10 ,
 161      >         /,4x,'    ===>  arret dans le gestionnaire de memoire')
 162         coergm = 4
 163       endif
 164 c
 165 c====
 166 c 3. appel aux programmes generiques
 167 c====
 168 c
 169       if ( coergm.eq.0 ) then
 170 c
 171       type1 = 'r'
 172 c
 173 c 3.1. ==> allongement d'un tableau conceptuellement 1D
 174 c          .  1     : tableau tab(d1,0) passant a tab(d1,d2)
 175 c          .  3     : tableau tab(0,d2) passant a tab(d1,d2)
 176 c          . 11, 21 : tableau tab(d1,d2), dont l'une des dimensions
 177 c                     vaut toujours 1 et dont l'autre augmente
 178 c          . 31     : tableau tab(0:d2) dont d2 augmente
 179 c          . 41     : tableau tab(0,0) passant a tab(1:d2) et d2>=0
 180 c          . 51     : tableau tab(0,0) passant a tab(d1:1) et d1>=0
 181 c
 182 cgn         write(ulsort,*) typmod, lgold, lgnew
 183       if ( typmod.eq.1 .or. typmod.eq.3 .or.
 184      >     typmod.eq.11 .or. typmod.eq.21 .or. typmod.eq.31 .or.
 185      >     typmod.eq.41 .or. typmod.eq.51 ) then
 186 c
 187          call gmextg
 188      >  ( nomtab,   point,  lgnew, iptold, lgold,   type1,
 189      >    minmer, ntrour, nballr, totalr,
 190      >    ptrour, ltrour, ptallr, lgallr, adur,
 191      >    nommxr, nomalr, satien, tablte )
 192 c
 193 c 1.2. ==> raccourcissement d'un tableau conceptuellement 1D
 194 c          . 12, 22 : tableau tab(d1,d2), dont l'une des dimensions
 195 c                     vaut toujours 1 et dont l'autre diminue
 196 c          . 32     : tableau tab(0:d2) dont d2 diminue
 197 c          attention : il ne faut pas traiter ici des diminutions
 198 c                      qui conduisent a un tableau de taille nulle
 199 c                      sinon on risque de creer une zone complete de
 200 c                      taille nulle, ce qui pose des problemes a la
 201 c                      compression. on passera donc par le cas general
 202 c                      ce qui permettra de regrouper ces tableaux de
 203 c                      taille nulle en tete de memoire.
 204 c
 205       elseif ( typmod.eq.12 .or. typmod.eq.22 .or.typmod.eq.32 ) then
 206 c
 207          detlg0 = .false.
 208 c
 209          call gmdesr ( nomtab, lgold-lgnew  , detlg0 )
 210 c
 211          satien = .true.
 212 c
 213 c rafraichissement eventuel du pointeur point
 214 c (dont la valeur a pu changer, en mode gm "dynamique")
 215 c
 216          nomvar = '        '
 217          if ( len(nomtab).gt.0 ) then
 218            nomvar(1:min(8,len(nomtab))) = nomtab(1:min(8,len(nomtab)))
 219          endif
 220          do 321 , i = 1, nballr
 221             if ( nomalr(i).eq.nomvar ) then
 222                point = adur(i)
 223                goto 322
 224             endif
 225   321    continue
 226 c
 227          write(ulsort,30000) nompro, nomvar
 228          coergm = 7
 229 c
 230 30000 format( 2x,'Anomalie dans le sp ',a6,
 231      >       /4x,'Le tableau a modifier ',a8,' n''a pas ete retrouve',
 232      >       /4x,'    ===>  arret dans le gestionnaire de memoire')
 233 c
 234   322    continue
 235 c
 236 c 3.3. ==> .  2     : tableau tab(d1,d2) passant a tab(d1,0)
 237 c          .  4     : tableau tab(d1,d2) passant a tab(0,d2)
 238 c          .  5     : pas de particularites
 239 c          . negatif : tableau de type tab(d1:d2) d1<=0 et d2>=0
 240 c
 241       else
 242 c
 243         satien = .false.
 244 c
 245          call gmmodg
 246      >  ( nomtab, lgold, lgnew,
 247      >    d1old,  d1new,  d2old,  d2new,
 248      >    point, iptold,   type1,
 249      >    minmer, ntrour, nballr, totalr,
 250      >    ptrour, ltrour, ptallr, lgallr, adur,
 251      >    nommxr, nomalr, tablte )
 252 c
 253       endif
 254 c
 255       endif
 256 c
 257 c====
 258 c 4. remplissage correct du tableau
 259 c====
 260 c
 261       if ( coergm.eq.0 ) then
 262 c
 263 c 4.1. ==> si le tableau a pu etre etendu sur sa fin, il faut
 264 c          initialiser a la valeur indefinie le complement
 265 c
 266       if ( satien ) then
 267 c
 268          if ( lindef.eq.0 ) then
 269             ideb = point+lgold
 270             ifin = point+lgnew-1
 271             do 41 , i= ideb ,ifin
 272               rmem(i) = rindef
 273    41       continue
 274          endif
 275 c
 276 c 4.2. ==> si le tableau a du etre recree ailleurs, il faut recopier
 277 c
 278       else
 279 c
 280 c 4.2.1. ==> on commence eventuellement a mettre une valeur par defaut
 281 c            partout
 282 c
 283         if ( lindef.eq.0 ) then
 284           ideb = point
 285           ifin = point+lgnew-1
 286           do 42 , i= ideb ,ifin
 287             rmem(i) = rindef
 288    42     continue
 289         endif
 290 c
 291 c 4.2.2. ==> copie des valeurs
 292 c 4.2.2.1. ==> tableau 1D :
 293 c avant  indice :  1   2   3   4
 294 c        valeur :  6   1   0   5
 295 c Il y a 2 cas de figure :
 296 c . allongement :
 297 c indice : 1   2   3   4   5   6
 298 c valeur : 6   1   0   5   x   x
 299 c . raccourcissement :
 300 c indice : 1   2
 301 c valeur : 6   1
 302 c
 303 c    il suffit de recopier les premieres valeurs aux premieres places.
 304 c    le nombre de valeurs a copier est le min entre le nombre qui etait
 305 c    present et le nombre qu'on veut
 306 c
 307         if ( typmod.ge.11 .and. typmod.le.32 ) then
 308 c
 309           kdeb = iptold
 310           kfin = kdeb + min(lgold,lgnew) - 1
 311           kaux = point - kdeb
 312           do 431 , k = kdeb , kfin
 313             rmem(kaux+k) = rmem(k)
 314   431     continue
 315 c
 316 c 4.2.2.2. ==> tableau tab(d1,d2) :
 317 c    il faut recopier les anciennes valeurs a leurs places :
 318 c    ex. a(1,1)=1    a(1,2)=2    a(1,3)=3
 319 c        a(2,1)=4    a(2,2)=5    a(2,3)=6
 320 c    le tableau a(2x3) est range ainsi : 1 4 2 5 3 6
 321 c    s'il devient un tableau a(3x3), les anciennes valeurs seront
 322 c    mises ainsi : 1 4 x 2 5 x 3 6 x
 323 c                         new(i,j) = old(i,j)
 324 c <==>         new (d1new*(j-1)+i) = old (d1old*(j-1)+i)
 325 c <==>  mem (point-1+d1new*(j-1)+i) = mem (iptold-1+d1old*(j-1)+i)
 326 c
 327 c    remarque : rien n'est a faire pour les cas 1 et 2 car l'un des
 328 c               deux tableaux (avant ou apres) est de longueur nulle.
 329 c
 330         elseif ( typmod.eq.5 ) then
 331 c
 332           d2min = min(d2old,d2new)
 333           d1min = min(d1old,d1new)
 334           do 432 , j = 1 , d2min
 335             kdeb = iptold + d1old*(j-1)
 336             kfin = kdeb + d1min - 1
 337             kaux = point - iptold + (d1new-d1old)*(j-1)
 338             do 4321 , k = kdeb , kfin
 339               rmem(kaux+k) = rmem(k)
 340  4321       continue
 341   432     continue
 342 c
 343 c 4.2.2.3. ==> tableau tab(d1:d2) :
 344 c    il faut recopier les anciennes valeurs a leurs places :
 345 c avant  indice :  -6  -5  -4  -3  -2  -1   0   1   2   3   4
 346 c        valeur :   3   2   8   2   7   9   6   1   0   5   3
 347 c Il y a 4 cas de figure :
 348 c . allongement des deux cotes :
 349 c   (d1old,d2old) = (-6,-8)  et (d2old,d2new) = (3,6)
 350 c indice : -8  -7  -6  -5  -4  -3  -2  -1   0   1   2   3   4   5   6
 351 c valeur :  x   x   3   2   8   2   7   9   6   1   0   5   3   x   x
 352 c . raccourcissement des deux cotes :
 353 c   (d1old,d2old) = (-6,-4)  et (d2old,d2new) = (3,2)
 354 c indice :                 -4  -3  -2  -1   0   1   2
 355 c valeur :                  8   2   7   9   6   1   0
 356 c . allongement vers les negatifs, raccourcissement vers les positifs :
 357 c   (d1old,d2old) = (-6,-8)  et (d2old,d2new) = (3,2)
 358 c indice : -8  -7  -6  -5  -4  -3  -2  -1   0   1   2
 359 c valeur :  x   x   3   2   8   2   7   9   6   1   0
 360 c . raccourcissement vers les negatifs, allongement vers les positifs :
 361 c   (d1old,d2old) = (-6,-4)  et (d2old,d2new) = (3,6)
 362 c indice :                 -4  -3  -2  -1   0   1   2   3   4   5   6
 363 c valeur :                  8   2   7   9   6   1   0   5   3   x   x
 364 c
 365 c   On doit donc transferer la partie correspondant a l'intervalle
 366 c   commun autour du point central. Ce point central correspond a ce
 367 c   qui est vu de l'exterieur comme tab(0).
 368 c   Son adresse memoire est :
 369 c   . dans l'ancien tableau : iptold - d1old
 370 c   . dans le nouveau tableau : point - d1new
 371 c   On doit transferer :
 372 c   . min(-d1old,-d1new) cases avant ce point central
 373 c   . min(d2old,d2new) cases apres ce point central
 374 c
 375         elseif ( typmod.le.0 ) then
 376 c
 377           kdeb = iptold - d1old - min(-d1old,-d1new)
 378           kfin = iptold - d1old + min(d2old,d2new)
 379           kaux = point - d1new - iptold + d1old
 380           do 4331 , k = kdeb , kfin
 381             rmem(kaux+k) = rmem(k)
 382  4331     continue
 383 c
 384         endif
 385 c
 386 c 4.2.3. ==> renommage du tableau
 387 c
 388          nomvar = '        '
 389          if ( len(nomtab).gt.0 ) then
 390            nomvar(1:min(8,len(nomtab))) = nomtab(1:min(8,len(nomtab)))
 391          endif
 392 c
 393          call gmdesa (nomvar)
 394          if ( coergm.ne.0 ) then
 395             write(ulsort,40001) nompro, nomvar
 396             call ugstop(nompro,ulsort,1,1,1)
 397          endif
 398 c
 399          do 4231 , i=1,nballr
 400             if ( nomalr(i).eq.tablte ) then
 401                nomalr(i) = nomvar
 402                goto 4232
 403             endif
 404  4231    continue
 405 c
 406          write(ulsort,40000) nompro, tablte
 407          call ugstop(nompro,ulsort,1,1,1)
 408 c
 409  4232    continue
 410          if ( nommxr.eq.tablte ) then
 411             nommxr = nomvar
 412          endif
 413 c
 414          call gbntde ( tablte, coergm )
 415 c
 416       endif
 417 c
 418 40000 format( 2x,'Anomalie dans le sp ',a6,
 419      >       /4x,'Le tableau temporaire ',a8,' n''a pas ete retrouve',
 420      >       /4x,'    ===>  arret dans le gestionnaire de memoire')
 421 c
 422 40001 format( 2x,'Anomalie dans le sp ',a6,
 423      >       /4x,'Desallocation temporaire du ',
 424      >       /4x,'tableau a modifier ',a8,' impossible',
 425      >       /4x,'    ===>  arret dans le gestionnaire de memoire')
 426 c
 427       endif
 428 c
 429       if ( coergm.ne.0 ) then
 430 c
 431 #include "envex2.h"
 432 c
 433       endif
 434 c
 435       end