src/tool/Gestion_MTU/gmdmpg.F

   1       subroutine gmdmpg ( minmeg, ntroug, nballg, ptroug, ltroug,
   2      >      ptallg, lgallg, adug, nommxg, nomalg, jgen, typtab,
   3      >      gmimp )
   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 .  - interet:
  24 c .       impression detaillee du contenu d'un tableau de travail
  25 c .          ( caracteristiques des trous et des zones allouees)
  26 c ______________________________________________________________________
  27 c .        .     .        .                                            .
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . minmeg . e   .        . valeur entiere memorisant la plus petite   .
  31 c .        .     .        . dimension du dernier trou afin de connaitre.
  32 c .        .     .        . le passage le plus delicat rencontre au    .
  33 c .        .     .        . cours de l'allocation. cette valeur est    .
  34 c .        .     .        . calculee apres compression                 .
  35 c . ntroug . e   .        . valeur entiere . nombre de trous present   .
  36 c . nballg . e   .        . nombre de tableaux deja alloues            .
  37 c . ptroug . e   .        . tableau entier contenant les pointeurs     .
  38 c .        .     .        . repertoriant la position des trous         .
  39 c . ltroug . e   .        . tableau entier contenant la long. des trous.
  40 c . ptallg . e   .        . tableau entier contenant les pointeurs     .
  41 c .        .     .        . repertoriant la position des tableaux      .
  42 c . lgallg . e   .        . tableau entier contenant la longueur des   .
  43 c .        .     .        . tableaux                                   .
  44 c . nommxg . e   .        . chaine de caractere(*8) contenant le nom du.
  45 c .        .     .        . plus grand tableau associe a minmeg        .
  46 c . nomalg . e   .        . tableau de chaines de caracteres contenant .
  47 c .        . e   .        . le nom associe a chaque tableau deja alloue.
  48 c . jgen   . e   .        . dimension reservee au depart
  49 c . typtab . e   .        . type du tableau :r,i,s,d,c                 .
  50 c . gmimp  . e   .    1   . 0 => pas d'impression                      .
  51 c .        .     .        . <=2 => impression simple                   .
  52 c .        .     .        . >2 => impression etendue                   .
  53 c ______________________________________________________________________
  54 c
  55 c ......................................................................
  56 c .    creation gn octobre 1993 a partir des versions specifiques
  57 c ......................................................................
  58 c
  59 c====
  60 c 0. declarations et dimensionnement
  61 c====
  62 c
  63 c 0.1. ==> generalites
  64 c
  65       implicit none
  66       save
  67 c
  68       character*6 nompro
  69       parameter ( nompro = 'GMDMPG' )
  70 c
  71 #include "genbla.h"
  72 #include "gmmaxt.h"
  73 #include "gmptrd.h"
  74 c
  75 c 0.2. ==> communs
  76 c
  77 #include "gmtail.h"
  78 #include "gmtyge.h"
  79 c
  80 #include "gmimpr.h"
  81 #include "gmlang.h"
  82 c
  83 c 0.3. ==> arguments
  84 c
  85       character*1 typtab
  86       character*8 nommxg, nomalg(maxtab)
  87       integer adug(maxtab)
  88 c
  89       integer minmeg, ntroug, nballg, jgen
  90       integer ptroug(maxtrs) , ltroug(maxtrs)
  91       integer ptallg(maxtab) , lgallg(maxtab)
  92       integer gmimp
  93 c
  94 c 0.4. ==> variables locales
  95 c
  96       integer maxg , mtot , ilgmax , maxiut, numtyp
  97       integer iaux , jaux , kaux , kaux1
  98       integer nbrreg , iall , ideb , ifin
  99       integer tabaux(0:maxtab)
 100 c
 101       character*14 saux14
 102       character*17 blabla(nblang,3)
 103       character*50 texte1
 104 c
 105       integer nbmess
 106       parameter ( nbmess = 21 )
 107       character*80 texte(nblang,nbmess)
 108 c
 109 c 0.5. ==> initialisations
 110 c ______________________________________________________________________
 111 c
 112 c====
 113 c 1. messages
 114 c====
 115 c
 116 #include "impr01.h"
 117 c
 118 #ifdef _DEBUG_HOMARD_
 119       write (ulsort,texte(langue,1)) 'Entree', nompro
 120       call dmflsh (iaux)
 121 #endif
 122 c
 123       texte(1,4) =
 124      > '(/18(''=''),'' Etat de la memoire en '',a17,17(''=''))'
 125       texte(1,5) =
 126      > '(/,''Nombre d''''objets alloues . . . . . . . :'',i12)'
 127       texte(1,6) = '(''Longueur totale en mots . . . . . . . :'',i12)'
 128       texte(1,7) = '(''Longueur totale en octets . . . . . . :'',i12)'
 129       texte(1,8) = '(''Maximum reserve a la compilation  . . :'',i12)'
 130       texte(1,9) = '(''Maximum reserve . . . . . . . . . . . :'',i12)'
 131       texte(1,10) ='(''Plus grand trou disponible. . . . . . :'',i12)'
 132       texte(1,11) ='(''Nombre de trous . . . . . . . . . . . :'',i12)'
 133       texte(1,12) =
 134      > '(''Maximum disponible actuel (cumul) . . :'',i12)'
 135       texte1 = '(''Plus grande zone deja allouee . : apres '',a8,'', '
 136 c               12 34567890123456789012345678901234567890123 45678 90
 137       texte(1,13) = texte1//'de taille '',i12)'
 138       texte(1,14) =
 139      > '(''- Trou no'',i5,'' adresse :'',i12,'', longueur :'',i12)'
 140       texte1 = '(/,''Region occupee no'',i5,/,''. Adresse :'',i12'
 141 c               1234 567890123456789012 3456789 012345678901234567 890
 142       texte(1,15) = texte1//''' . Longueur :'',i12)'
 143       texte1 = '(11(''=''),'' Fin de la gestion de la memoire en '',  '
 144 c               12345 67 890 1234567890123456789012345678901234567 890
 145       texte(1,19) = texte1//'a17,11(''='')/)'
 146       texte(1,20) =
 147      >'(''Type '''',a1,'''' inconnu. Il faut r, i, d, s ou c.'')'
 148       texte(1,21) = '(''La memoire est geree dynamiquement.'')'
 149 c
 150       texte(2,4) =
 151      > '(/18(''=''),'' Status of memory in '',a17,17(''=''))'
 152       texte(2,5) =
 153      > '(/,''Number of allocated objects . . . . . :'',i12)'
 154       texte(2,6) = '(''Total length in words . . . . . . . . :'',i12)'
 155       texte(2,7) = '(''Total length in bits  . . . . . . . . :'',i12)'
 156       texte(2,8) = '(''Maximum reserved in compilation . . . :'',i12)'
 157       texte(2,9) = '(''Maximum reserved  . . . . . . . . . . :'',i12)'
 158       texte(2,10) ='(''Greatest available hole . . . . . . . :'',i12)'
 159       texte(2,11) ='(''Number of holes . . . . . . . . . . . :'',i12)'
 160       texte(2,12) =
 161      > '(''Current available maximum (total) . . :'',i12)'
 162       texte1 = '(''Greatest zone already allocated : after '',a8,  '
 163 c               12 345678901234567890123456789012345678901234567890
 164       texte(2,13) = texte1//''', of size '',i12)'
 165       texte1 ='(''- Hole #'',i5,'' adress :'',i12,'', length :'''
 166 c              12 345678901 23456 7890123456789012 34567 89012345678 90
 167       texte(2,14) = texte1//',i12)'
 168       texte1 = '(/,''Occupied region #'',i5,/,''. Adress:'',i12,'
 169 c               1234 567890123456789012 3456789 01234567890123456 7890
 170       texte(2,15) = texte1//''' . Length:'',i12)'
 171       texte(2,17) = '(65(''-''))'
 172       texte1 = '(14(''=''),'' End of the memory gestion in '','
 173 c               12 34567890123456789012 3456789 012345678901234567890
 174       texte(2,19) = texte1//'a17,13(''='')/)'
 175       texte(2,20) =
 176      >'(''Type '''',a1,'''' unknown. Only r, i, d, s or c.'')'
 177       texte(2,21) = '(''Memory is used dynamically.'')'
 178 c
 179       blabla(1,1) = 'reel ============'
 180       blabla(1,2) = 'entier =========='
 181       blabla(1,3) = 'caractere ======='
 182 c
 183       blabla(2,1) = 'real ============'
 184       blabla(2,2) = 'integer ========='
 185       blabla(2,3) = 'character ======='
 186 c
 187  1001 format (74('-'))
 188  1002 format ('! Tableau  !    Taille',a,'Adresse  ',
 189      >a,'Adresse utile !')
 190  1003 format ('! ',a8,' !',i14,' !',i21,' !',i21,' !')
 191       saux14 = '     !        '
 192 c
 193 c     Pour eviter un message de ftnchek :
 194       tabaux(0) = 0
 195 c
 196 c====
 197 c  2. preliminaires
 198 c====
 199 c
 200       if ( typtab.eq.'r' .or. typtab.eq.'R' ) then
 201          numtyp  = 1
 202       elseif ( typtab.eq.'i' .or. typtab.eq.'I' ) then
 203          numtyp  = 2
 204       elseif ( typtab.eq.'s' .or. typtab.eq.'S' ) then
 205          numtyp  = 3
 206       else
 207         write (ulsort,texte(langue,1)) 'Sortie', nompro
 208          write (ulsort,texte(langue,20)) typtab
 209          call ugstop( nompro,ulsort,1,0,1)
 210       endif
 211 c
 212 c====
 213 c 3. bilan de l'etat de la memoire
 214 c====
 215 c
 216 c 3.1. ==> generalites
 217 c
 218       write (ulsort,texte(langue,4)) blabla(langue,numtyp)
 219       write (ulsort,texte(langue,5)) nballg
 220 c
 221       iaux = 0
 222       do 31 , kaux = 1 , nballg
 223         iaux = iaux + lgallg(kaux)
 224    31 continue
 225       write (ulsort,texte(langue,6)) iaux
 226 c
 227       if ( typtab.eq.'i'.or.typtab.eq.'I') then
 228         kaux = tentie
 229       elseif ( typtab.eq.'s'.or.typtab.eq.'S') then
 230         kaux = tchain
 231       elseif ( typtab.eq.'r'.or.typtab.eq.'R') then
 232         kaux = treel
 233       endif
 234       iaux = kaux*iaux
 235       write (ulsort,texte(langue,7)) iaux
 236 c
 237       call gmmaxi( maxg , mtot , ntroug, ltroug )
 238 c
 239       ilgmax = jgen
 240       maxiut = ilgmax - minmeg
 241 c
 242       if ( modgm.le.1 ) then
 243         if ( modgm.eq.0 ) then
 244           write (ulsort,texte(langue,8)) ilgmax
 245         else
 246           write (ulsort,texte(langue,9)) ilgmax
 247         endif
 248         write (ulsort,texte(langue,10)) maxg
 249         write (ulsort,texte(langue,11)) ntroug
 250         write (ulsort,texte(langue,12)) mtot
 251         if ( maxiut.ne.1 ) then
 252            write (ulsort,texte(langue,13)) nommxg, maxiut
 253         endif
 254         if (ntroug.ne.0) then
 255           write (ulsort,texte(langue,14))
 256      >                    (iaux,ptroug(iaux),ltroug(iaux),iaux=1,ntroug)
 257         endif
 258       else
 259         write (ulsort,texte(langue,21))
 260       endif
 261 c
 262 c 3.2. ==>  chaque region precedant un trou, sauf la derniere
 263 c           remarque : en dynamique, la notion de region n'existe pas.
 264 c                      Il n'y a pas de trou.
 265 c
 266 c            ideb = position de la fin du trou precedent
 267 c                 = position du debut de la region
 268 c            ifin = position du debut du trou
 269 c                 = position de la fin de la region
 270 c            iall = numero du premier tableau de la region
 271 c            kaux1 = numero du premier tableau de la region suivante
 272 c
 273       if ( gmimp.gt.2 ) then
 274 c
 275       nbrreg = 1
 276       ideb = ptrdeb
 277       iall = 1
 278 c
 279       do 32 , iaux = 1 , ntroug
 280 c
 281         ifin = ptroug(iaux)
 282 c
 283 c 3.2.1. ==> recherche du numero du premier tableau de la region
 284 c              suivante, eventuellement fictif si on arrive au bout
 285 c
 286         do 321, kaux = iall , nballg
 287           if ( ptallg(kaux).gt.ifin ) then
 288              kaux1 = kaux
 289              go to 322
 290           endif
 291   321   continue
 292 c
 293         kaux1 = nballg + 1
 294 c
 295   322   continue
 296 c
 297 c 3.2.2. ==> impression des caracteristiques de la region, si elle
 298 c              n'est pas vide
 299 c
 300         if ( kaux1-1.ge.iall ) then
 301 c
 302           write (ulsort,texte(langue,15)) nbrreg, ideb, ifin-ideb
 303           write (ulsort,1001)
 304           write (ulsort,1002) saux14, saux14
 305           write (ulsort,1001)
 306           do 323, kaux = iall , kaux1-1
 307             write (ulsort,1003) nomalg(kaux), lgallg(kaux),
 308      >                        ptallg(kaux), adug(kaux)
 309   323     continue
 310           write (ulsort,1001)
 311           write (ulsort,*) ' '
 312 c
 313         endif
 314 c
 315 c 3.2.3. ==> reactualisation des grandeurs pour la region suivante
 316 c
 317         iall = kaux1
 318         ideb = ifin + ltroug(iaux)
 319         nbrreg = nbrreg + 1
 320 c
 321    32 continue
 322 c
 323 c 3.3. ==> on imprime la fin
 324 c          . l'integralite, s'il n'y a pas de trou
 325 c          . ce qui suit le dernier trou, s'il y en a
 326 c
 327       if ( iall.le.nballg ) then
 328 c
 329 c 3.3.1. ==> tri par valeur d'adresse croissante
 330 c
 331         kaux = 0
 332         do 331 , iaux = iall , nballg
 333           do 3311 , jaux = 1 , kaux
 334             if ( adug(tabaux(jaux)).gt.adug(iaux) ) then
 335               kaux1 = jaux
 336               goto 3312
 337             endif
 338  3311     continue
 339           kaux1 = kaux + 1
 340  3312     continue
 341           do 3313 , jaux = kaux , kaux1 , -1
 342             tabaux(jaux+1) = tabaux(jaux)
 343  3313     continue
 344           tabaux(kaux1) = iaux
 345           kaux = kaux + 1
 346   331   continue
 347 c
 348 c 3.3.2. ==> affichage
 349 c
 350         if ( modgm.le.1 ) then
 351           write (ulsort,texte(langue,15)) nbrreg, ideb,
 352      >                                    ilgmax+ptrdeb-ideb
 353         endif
 354         write (ulsort,1001)
 355         write (ulsort,1002) saux14, saux14
 356         write (ulsort,1001)
 357         do 33, kaux = 1, kaux
 358           kaux1 = tabaux(kaux)
 359           write (ulsort,1003) nomalg(kaux1), lgallg(kaux1),
 360      >                      ptallg(kaux1), adug(kaux1)
 361    33   continue
 362         write (ulsort,1001)
 363         write (ulsort,*) ' '
 364 c
 365       endif
 366 c
 367       endif
 368 c
 369 c 3.4. ==> fin
 370 c
 371       write (ulsort,texte(langue,19)) blabla(langue,numtyp)
 372 c
 373 #ifdef _DEBUG_HOMARD_
 374       write (ulsort,texte(langue,1)) 'Sortie', nompro
 375       call dmflsh (iaux)
 376 #endif
 377 c
 378       end