src/tool/Gestion_MTU/gbralo.F

   1       subroutine gbralo ( type1, long, iad, 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     Re-allocation,
  23 c     utilisee uniquement en mode gm dynamique,
  24 c     dans le sens reduction de taille,
  25 c     avec une taille finale > 0
  26 c ______________________________________________________________________
  27 c .        .     .        .                                            .
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . type1  . e   . char*1 . type du tableau a reallouer                .
  31 c . long   . e   .    1   . nouvelle longueur du tableau               .
  32 c . iad    . es  .    1   . adresse du premier element du tableau      .
  33 c .        .     .        . (adresse memoire)                          .
  34 c . codret .  s  .    1   . code de retour                             .
  35 c . codret .  s  .    1   . 0  : tout va bien                          .
  36 c ______________________________________________________________________
  37 c
  38 c====
  39 c 0. declarations et dimensionnement
  40 c====
  41 c
  42 c 0.1. ==> generalites
  43 c
  44       implicit none
  45       save
  46 c
  47 c 0.2. ==> communs
  48 c
  49 #include "gmtail.h"
  50 c
  51 #include "gmimpr.h"
  52 c
  53 c 0.3. ==> arguments
  54 c
  55       character*1 type1
  56       integer long, iad
  57       integer codret
  58 c
  59 c 0.4. ==> variables locales
  60 c
  61       integer ltype, size
  62       character*60 texte(5)
  63 c
  64 c 0.5. ==> initialisations
  65 c
  66 c ______________________________________________________________________
  67 c
  68 c====
  69 c 1. messages
  70 c====
  71 c
  72       texte(3) = 'L''adresse est hors des limites de la pile (heap). '
  73       texte(4) = 'La zone a deja ete liberee.                       '
  74       texte(5) = 'L''adresse n''est pas au debut d''un bloc.           '
  75 c
  76 c====
  77 c 2. recherche de la taille selon le type de tableau a reallouer
  78 c====
  79 c
  80       if ( type1.eq.'i'.or.type1.eq.'I' ) then
  81        ltype = tentie
  82       elseif ( type1.eq.'s'.or.type1.eq.'S' ) then
  83        ltype = tchain
  84       elseif ( type1.eq.'r'.or.type1.eq.'R' ) then
  85        ltype = treel
  86       else
  87         write(ulsort,*) ' gbralo type inconnu ', type1
  88         call ugstop('gbralo',ulsort,0,1,1)
  89       endif
  90 c
  91 c====
  92 c 3. reallocation effective
  93 c====
  94 c (attention: dmralo ne garantit pas que l'adresse de depart iad
  95 c             ne sera pas changee)
  96 c
  97       size = ltype*long
  98 c
  99 cgn      write(ulsort,*) 'appel de dmralo avec iad = ', iad
 100 cgn      write(ulsort,*) 'appel de dmralo avec size = ', size
 101       call dmralo ( iad, size, codret )
 102 cgn      write(ulsort,*) 'retour de dmralo'
 103 c
 104       if ( codret.ne.0 ) then
 105         write (ulsort,*) ' GBRALO : erreur a la re-allocation'
 106         write (ulsort,*) 'Code de retour de DMRALO : ', codret
 107         if ( codret.ge.-5 .and. codret.le.-3 ) then
 108           write (ulsort,*) texte(abs(codret))
 109         endif
 110         write (ulsort,*) 'Type          : ', type1
 111         write (ulsort,*) 'Adresse       : ', iad
 112         write (ulsort,*) 'Taille voulue : ', long
 113       endif
 114 c
 115       end