src/tool/Utilitaire/utad07.F

   1       subroutine utad07 ( ncequi,
   2      >                    nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu,
   3      >                    nbeqnn, nbeqmn, nbeqan, nbeqtn, nbeqqn,
   4      >                    adeqno, adeqmp, adeqar, adeqtr, adeqqu,
   5      >                    adeqte, adeqhe,
   6      >                    ulsort, langue, codret )
   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    UTilitaire - ADresses - phase 07
  28 c    --           --               --
  29 c ______________________________________________________________________
  30 c   Modification des longueurs des tableaux pour une entite MC_Equ
  31 c   et recuperation de leurs adresses
  32 c   Remarque : le code de retour en entree ne doit pas etre ecrase
  33 c              brutalement ; il doit etre cumule avec les operations
  34 c              de ce programme
  35 c   Remarque : utacme et utad07 sont similaires
  36 c ______________________________________________________________________
  37 c .        .     .        .                                            .
  38 c .  nom   . e/s . taille .           description                      .
  39 c .____________________________________________________________________.
  40 c . ncequi . e   . char8  . nom de la branche Equivalt maillage calcul .
  41 c . nbeqno . e   .    1   . nombre total de noeuds dans les equivalen. .
  42 c . nbeqmp . e   .    1   . nombre total de mailles-points dans les eq..
  43 c . nbeqar . e   .    1   . nombre total d'aretes dans les eq.         .
  44 c . nbeqtr . e   .    1   . nombre total de triangles dans les eq.     .
  45 c . nbeqqu . e   .    1   . nombre total de quadrangles dans les eq.   .
  46 c . nbeqnn . e   .    1   . nouveau nbeqno                             .
  47 c . nbeqmn . e   .    1   . nouveau nbeqmp                             .
  48 c . nbeqan . e   .    1   . nouveau nbeqar                             .
  49 c . nbeqtn . e   .    1   . nouveau nbeqtr                             .
  50 c . nbeqqn . e   .    1   . nouveau nbeqqu                             .
  51 c . adeqno .   s .    1   . adresse de la branche Noeud                .
  52 c . adeqmp .   s .    1   . adresse de la branche Point                .
  53 c . adeqar .   s .    1   . adresse de la branche Arete                .
  54 c . adeqtr .   s .    1   . adresse de la branche Trian                .
  55 c . adeqqu .   s .    1   . adresse de la branche Quadr                .
  56 c . adeqte .   s .    1   . adresse de la branche Tetra                .
  57 c . adeqhe .   s .    1   . adresse de la branche Hexae                .
  58 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  59 c . langue . e   .    1   . langue des messages                        .
  60 c .        .     .        . 1 : francais, 2 : anglais                  .
  61 c . codret . es  .    1   . code de retour des modules                 .
  62 c .        .     .        . 0 : pas de probleme                        .
  63 c .        .     .        . autre : probleme dans l'allocation         .
  64 c ______________________________________________________________________
  65 c
  66 c====
  67 c 0. declarations et dimensionnement
  68 c====
  69 c
  70 c 0.1. ==> generalites
  71 c
  72       implicit none
  73       save
  74 c
  75       character*6 nompro
  76       parameter ( nompro = 'UTAD07' )
  77 c
  78 #include "nblang.h"
  79 c
  80 c 0.2. ==> communs
  81 c
  82 #include "envex1.h"
  83 c
  84 #include "impr02.h"
  85 c
  86 c 0.3. ==> arguments
  87 c
  88       character*8 ncequi
  89 c
  90       integer nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu
  91       integer nbeqnn, nbeqmn, nbeqan, nbeqtn, nbeqqn
  92       integer adeqno, adeqmp, adeqar, adeqtr, adeqqu
  93       integer adeqte, adeqhe
  94 c
  95       integer ulsort, langue, codret
  96 c
  97 c 0.4. ==> variables locales
  98 c
  99       integer un
 100       parameter ( un = 1 )
 101 c
 102       integer iaux
 103       integer codre1, codre2, codre3, codre4, codre5
 104       integer codre0
 105       integer nbeqte, nbeqhe
 106 c
 107       integer nbmess
 108       parameter ( nbmess = 10 )
 109       character*80 texte(nblang,nbmess)
 110 c
 111 c 0.5. ==> initialisations
 112 c ______________________________________________________________________
 113 c
 114 c====
 115 c 1. messages
 116 c====
 117 c
 118 #include "impr01.h"
 119 c
 120 #ifdef _DEBUG_HOMARD_
 121       write (ulsort,texte(langue,1)) 'Entree', nompro
 122       call dmflsh (iaux)
 123 #endif
 124 c
 125       texte(1,4) =
 126      > '(''Rellocation des equivalences du maillage de calcul'')'
 127       texte(1,5) = '(''Nombre d''''equivalences : '',i4)'
 128       texte(1,6) = '(''Nombre de paires de '',a14,'' : '',i4)'
 129       texte(1,7) = '(''Impossible d''''ecrire les attributs de '',a)'
 130       texte(1,8) = '(''Impossible de reallouer les branches de '',a)'
 131       texte(1,9) = '(''Codes : '',7i3)'
 132 c
 133       texte(2,4) =
 134      > '(''Re-allocation of equivalences of calculation mesh'')'
 135       texte(2,5) = '(''Number of equivalences: '',i4)'
 136       texte(2,6) = '(''Number of pairs of '',a14,'': '',i4)'
 137       texte(2,7) = '(''Attributes of '',a,'' cannot be written.'')'
 138       texte(2,8) = '(''Branches of '',a,'' cannot be re-allocated.'')'
 139       texte(2,9) = '(''Codes: '',7i3)'
 140 c
 141 #ifdef _DEBUG_HOMARD_
 142       write(ulsort,texte(langue,4))
 143       write(ulsort,texte(langue,6)) mess14(langue,3,-1), nbeqno
 144       write(ulsort,texte(langue,6)) mess14(langue,3,0), nbeqmp
 145       write(ulsort,texte(langue,6)) mess14(langue,3,1), nbeqar
 146       write(ulsort,texte(langue,6)) mess14(langue,3,2), nbeqtr
 147       write(ulsort,texte(langue,6)) mess14(langue,3,4), nbeqqu
 148       write(ulsort,texte(langue,6)) mess14(langue,3,-1), nbeqnn
 149       write(ulsort,texte(langue,6)) mess14(langue,3,0), nbeqmn
 150       write(ulsort,texte(langue,6)) mess14(langue,3,1), nbeqan
 151       write(ulsort,texte(langue,6)) mess14(langue,3,2), nbeqtn
 152       write(ulsort,texte(langue,6)) mess14(langue,3,4), nbeqqn
 153 #endif
 154 c
 155 c====
 156 c 2. attributs
 157 c====
 158 c
 159       if ( codret.eq.0 ) then
 160 c
 161       call gmecat ( ncequi, 2, nbeqnn, codre1 )
 162       call gmecat ( ncequi, 3, nbeqmn, codre2 )
 163       call gmecat ( ncequi, 4, nbeqan, codre3 )
 164       call gmecat ( ncequi, 5, nbeqtn, codre4 )
 165       call gmecat ( ncequi, 6, nbeqqn, codre5 )
 166 c
 167       codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 168       codret = max ( abs(codre0), codret,
 169      >               codre1, codre2, codre3, codre4, codre5 )
 170 c
 171       if ( codret.ne.0 ) then
 172         write(ulsort,texte(langue,7)) ncequi
 173       endif
 174 c
 175       endif
 176 c
 177 c====
 178 c 3. redimensionnement
 179 c====
 180 c 3.1. ==> Noeuds, mailles-point, aretes et faces
 181 c
 182       if ( codret.eq.0 ) then
 183 c
 184       call gmmod ( ncequi//'.Noeud',
 185      >             adeqno, 2*nbeqno, 2*nbeqnn, un, un, codre1 )
 186       call gmmod ( ncequi//'.Point',
 187      >             adeqmp, 2*nbeqmp, 2*nbeqmn, un, un, codre2 )
 188       call gmmod ( ncequi//'.Arete',
 189      >             adeqar, 2*nbeqar, 2*nbeqan, un, un, codre3 )
 190       call gmmod ( ncequi//'.Trian',
 191      >             adeqtr, 2*nbeqtr, 2*nbeqtn, un, un, codre4 )
 192       call gmmod ( ncequi//'.Quadr',
 193      >             adeqqu, 2*nbeqqu, 2*nbeqqn, un, un, codre5 )
 194 c
 195       codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 196       codret = max ( abs(codre0), codret,
 197      >               codre1, codre2, codre3, codre4, codre5 )
 198 c
 199       if ( codret.ne.0 ) then
 200         write(ulsort,texte(langue,8)) ncequi
 201         write(ulsort,texte(langue,9))
 202      >               codre1, codre2, codre3, codre4, codre5
 203       endif
 204 c
 205       endif
 206 c
 207       if ( codret.eq.0 ) then
 208 c
 209       nbeqno = nbeqnn
 210       nbeqmp = nbeqmn
 211       nbeqar = nbeqan
 212       nbeqtr = nbeqtn
 213       nbeqqu = nbeqqn
 214 c
 215       endif
 216 c
 217 c 3.2. ==> Volumes dans le cas du recollement
 218 c
 219       if ( codret.eq.0 ) then
 220 c
 221       call gmliat ( ncequi, 7, nbeqte, codre1 )
 222       call gmliat ( ncequi, 8, nbeqhe, codre2 )
 223 c
 224       codre0 = min ( codre1, codre2 )
 225       codret = max ( abs(codre0), codret,
 226      >               codre1, codre2 )
 227 c
 228       endif
 229 c
 230       if ( codret.eq.0 ) then
 231 c
 232       if ( nbeqte.gt.0 ) then
 233         call gmecat ( ncequi, 6, nbeqtr+nbeqqu, codre1 )
 234         call gmmod ( ncequi//'.Tetra', adeqte,
 235      >               2, 2, nbeqte, nbeqtr+nbeqqu, codre2 )
 236       else
 237         codre1 = 0
 238         codre2 = 0
 239       endif
 240       if ( nbeqhe.gt.0 ) then
 241         call gmecat ( ncequi, 7, nbeqtr+nbeqqu, codre3 )
 242         call gmmod ( ncequi//'.Hexae', adeqhe,
 243      >               2, 2, nbeqhe, nbeqtr+nbeqqu, codre4 )
 244       else
 245         codre3 = 0
 246         codre4 = 0
 247       endif
 248 c
 249       codre0 = min ( codre1, codre2, codre3, codre4 )
 250       codret = max ( abs(codre0), codret,
 251      >               codre1, codre2, codre3, codre4 )
 252 c
 253       endif
 254 c
 255 c====
 256 c 4. la fin
 257 c====
 258 c
 259       if ( codret.ne.0 ) then
 260 c
 261 #include "envex2.h"
 262 c
 263       write (ulsort,texte(langue,1)) 'Sortie', nompro
 264       write (ulsort,texte(langue,2)) codret
 265       endif
 266 c
 267 #ifdef _DEBUG_HOMARD_
 268       write (ulsort,texte(langue,1)) 'Sortie', nompro
 269       call dmflsh (iaux)
 270 #endif
 271 c
 272       end