src/tool/Utilitaire/utmfen.F

   1       subroutine utmfen ( nhenti, nhent2, nbent2,
   2      >                    ulsort, langue, codret)
   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    UTilitaire - passage de Mere a Fille pour les ENtites
  24 c    --                      -      -              --
  25 c ______________________________________________________________________
  26 c .        .     .        .                                            .
  27 c .  nom   . e/s . taille .           description                      .
  28 c .____________________________________________________________________.
  29 c . nhenti . e   . char8  . nom de l'objet decrivant l'entite          .
  30 c . nhent2 . e   . char8  . nom de l'objet decrivant l'entite frere    .
  31 c . nbent2 . e   .   1    . nombre d'entite frere                      .
  32 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  33 c . langue . e   .    1   . langue des messages                        .
  34 c .        .     .        . 1 : francais, 2 : anglais                  .
  35 c . codret . es  .    1   . code de retour des modules                 .
  36 c .        .     .        . 0 : pas de probleme                        .
  37 c .        .     .        . 1 : probleme                               .
  38 c ______________________________________________________________________
  39 c
  40 c====
  41 c 0. declarations et dimensionnement
  42 c====
  43 c
  44 c 0.1. ==> generalites
  45 c
  46       implicit none
  47       save
  48 c
  49       character*6 nompro
  50       parameter ( nompro = 'UTMFEN' )
  51 c
  52 #include "nblang.h"
  53 c
  54 c 0.2. ==> communs
  55 c
  56 #include "envex1.h"
  57 c
  58 #include "gmenti.h"
  59 c
  60 c 0.3. ==> arguments
  61 c
  62       character*8 nhenti, nhent2
  63 c
  64       integer nbent2
  65 c
  66       integer ulsort, langue, codret
  67 c
  68 c 0.4. ==> variables locales
  69 c
  70       integer nbenti, pfille, pmere, lamere
  71       integer numead
  72       integer pfill2
  73       integer iaux, jaux
  74       integer ideb, ifin, ideb2
  75       integer codre1, codre2
  76       integer codre0
  77 c
  78       integer nbmess
  79       parameter ( nbmess = 10 )
  80       character*80 texte(nblang,nbmess)
  81 c
  82 c 0.5. ==> initialisations
  83 c ______________________________________________________________________
  84 c
  85 c====
  86 c 1. messages
  87 c====
  88 c
  89 #include "impr01.h"
  90 c
  91 #ifdef _DEBUG_HOMARD_
  92       write (ulsort,texte(langue,1)) 'Entree', nompro
  93       call dmflsh (iaux)
  94 #endif
  95 c
  96       texte(1,4) = '(''... Reperage des filles a partir des meres'')'
  97       texte(1,5) = '(''. Nombre d''''entites           :'',i10)'
  98       texte(1,6) = '(''. Nombre d''''entites soeurs    :'',i10)'
  99       texte(1,7) = '(''. Numero de la mere adoptive :'',i10))'
 100 c
 101       texte(2,4) = '(''... Son arrays from father arrays'')'
 102       texte(2,5) = '(''. Number of entities        :'',i10)'
 103       texte(2,6) = '(''. Number of brother entities:'',i10)'
 104       texte(2,7) = '(''. Number for adoptive mother:'',i10))'
 105 c
 106 #include "impr03.h"
 107 c
 108 #ifdef _DEBUG_HOMARD_
 109       write (ulsort,texte(langue,4))
 110 #endif
 111 c
 112 c====
 113 c 2. recuperation des donnees du maillage d'entree
 114 c====
 115 c
 116 #ifdef _DEBUG_HOMARD_
 117       call gmprsx (nompro, nhenti )
 118 #endif
 119 c
 120 c 2.1. ==> Parente
 121 c
 122       call gmliat ( nhenti, 1, nbenti, codre1 )
 123       call gmadoj ( nhenti//'.Mere', pmere, iaux, codre2 )
 124 c
 125       codre0 = min ( codre1, codre2 )
 126       codret = max ( abs(codre0), codret,
 127      >               codre1, codre2 )
 128 c
 129 #ifdef _DEBUG_HOMARD_
 130       write (ulsort,texte(langue,5)) nbenti
 131       write (ulsort,texte(langue,6)) nbent2
 132 #endif
 133 c
 134 c 2.2. ==> Eventuelle parente adoptive
 135 c
 136       if ( codret.eq.0 ) then
 137 c
 138 #ifdef _DEBUG_HOMARD_
 139       write (ulsort,texte(langue,3)) 'UTAD03', nompro
 140 #endif
 141       iaux = 5
 142       call utad03 ( iaux, nhenti,
 143      >              jaux, jaux, numead,
 144      >              jaux, jaux,
 145      >              ulsort, langue, codret )
 146 c
 147 #ifdef _DEBUG_HOMARD_
 148       write (ulsort,texte(langue,7)) numead
 149 #endif
 150 c
 151       endif
 152 c
 153 c====
 154 c 3. Creation du tableau des filles
 155 c    Attention, la convention homard veut que le tableau soit cree,
 156 c    meme s'il est vide
 157 c====
 158 #ifdef _DEBUG_HOMARD_
 159       write (ulsort,90002) '3. Creation tableau ; codret', codret
 160 #endif
 161 c
 162       if ( codret.eq.0 ) then
 163 c
 164 #ifdef _DEBUG_HOMARD_
 165       if ( nbenti.le.50 ) then
 166         call gmprsx (nompro, nhenti//'.Mere' )
 167       else
 168         call gmprot (nompro, nhenti//'.Mere', 1, 50)
 169         call gmprot (nompro, nhenti//'.Mere', max(51,nbenti-50),nbenti )
 170       endif
 171 #endif
 172 c
 173       call gmobal ( nhenti//'.Fille', codre1 )
 174 c
 175       if ( codre1.eq.0 ) then
 176 c
 177 #ifdef _DEBUG_HOMARD_
 178       write (ulsort,90002) 'Allocation avec nbenti', nbenti
 179 #endif
 180         call gmaloj ( nhenti//'.Fille', ' ', nbenti, pfille, codre2 )
 181 c
 182         if ( codre2.eq.0 ) then
 183 c
 184         ideb = pfille
 185         ifin = pfille + nbenti - 1
 186         do 31 , iaux = ideb , ifin
 187           imem(iaux) = 0
 188    31   continue
 189 c
 190         endif
 191 c
 192       elseif ( codre1.eq.2 ) then
 193 c
 194         call gmadoj ( nhenti//'.Fille', pfille, iaux, codre2 )
 195         codre1 = 0
 196 c
 197       else
 198         codre2 = 2
 199 c
 200       endif
 201 c
 202       codre0 = min ( codre1, codre2 )
 203       codret = max ( abs(codre0), codret,
 204      >               codre1, codre2 )
 205 c
 206       endif
 207 c
 208 c====
 209 c 4. Entite frere eventuelle
 210 c====
 211 #ifdef _DEBUG_HOMARD_
 212       write (ulsort,90002) '4. Entite frere eventuelle ; codret', codret
 213 #endif
 214 c
 215       if ( codret.eq.0 ) then
 216 c
 217       if ( nbent2.ne.0 ) then
 218 c
 219         call gmobal ( nhent2//'.Fille', codre1 )
 220 c
 221         if ( codre1.eq.0 ) then
 222 c
 223           call gmaloj ( nhent2//'.Fille', ' ', nbent2, pfill2, codre2 )
 224 c
 225           if ( codre2.eq.0 ) then
 226 c
 227           ideb = pfill2
 228           ifin = pfill2 + nbent2 - 1
 229           do 41 , iaux = ideb , ifin
 230             imem(iaux) = 0
 231    41     continue
 232 c
 233           endif
 234 c
 235         elseif ( codre1.eq.2 ) then
 236 c
 237           call gmadoj ( nhent2//'.Fille', pfill2, iaux, codre2 )
 238           codre1 = 0
 239 c
 240         else
 241           codre2 = 2
 242 c
 243         endif
 244 c
 245         codre0 = min ( codre1, codre2 )
 246         codret = max ( abs(codre0), codret,
 247      >                 codre1, codre2 )
 248 c
 249       endif
 250 c
 251       endif
 252 c
 253 c====
 254 c 5. traitement
 255 c    pour chaque entite qui est fille, on marque la mere
 256 c    attention : la convention homard veut que seule la fille
 257 c                ainee soit marquee
 258 c====
 259 #ifdef _DEBUG_HOMARD_
 260       write (ulsort,90002) '5. traitement ; codret', codret
 261 #endif
 262 c
 263       if ( codret.eq.0 ) then
 264 c
 265       ideb = pfille - 1
 266       ifin = nbenti - 1
 267 c
 268 c 5.1. ==> sans entite frere
 269 c
 270       if ( nbent2.eq.0 ) then
 271 c
 272         do 51 , iaux = 0 , ifin
 273 c
 274           lamere = imem(pmere+iaux)
 275 c
 276 c       lamere > 0 : il existe une mere
 277 c
 278           if ( lamere.gt.0 ) then
 279             if ( imem(ideb+lamere).eq.0 ) then
 280               imem(ideb+lamere) = iaux + 1
 281             endif
 282           endif
 283 c
 284    51   continue
 285 c
 286 c 5.2. ==> avec une entite frere
 287 c
 288       else
 289 c
 290         ideb2 = pfill2 - 1
 291 c
 292         do 52 , iaux = 0 , ifin
 293 c
 294           lamere = imem(pmere+iaux)
 295 c
 296 c       lamere > 0 : il existe une mere et elle est de meme type
 297 c                    que la fille
 298 c
 299 cgn          print *,'Face =', iaux+1,' ==> lamere =', lamere
 300           if ( lamere.gt.0 ) then
 301             if ( imem(ideb+lamere).eq.0 ) then
 302               imem(ideb+lamere) = iaux + 1
 303             endif
 304 c
 305 c       lamere < 0 : il existe une mere et elle est du type frere de
 306 c                    celui de la fille
 307 c       attention : il ne faut rien faire quand ce numero vaut
 308 c                   le numero de mere adoptive. Cela signifie que c'est
 309 c                   une mere adoptive pour traiter les non conformites
 310 c                   initiales. S'il n'y en a pas, numead vaut 0
 311 c
 312           elseif ( lamere.lt.0 .and. lamere.ne.numead ) then
 313             if ( imem(ideb2-lamere).eq.0 ) then
 314               imem(ideb2-lamere) = -( iaux + 1 )
 315             endif
 316           endif
 317 c
 318    52   continue
 319 c
 320       endif
 321 c
 322 #ifdef _DEBUG_HOMARD_
 323       if ( nbenti.le.50 ) then
 324         call gmprsx (nompro, nhenti//'.Mere' )
 325       else
 326         call gmprot (nompro, nhenti//'.Mere', 1, 50)
 327         call gmprot (nompro, nhenti//'.Mere', max(51,nbenti-50), nbenti)
 328       endif
 329       if ( nbenti.le.50 ) then
 330         call gmprsx (nompro, nhenti//'.Fille' )
 331       else
 332         call gmprot (nompro, nhenti//'.Fille', 1, 50)
 333         call gmprot (nompro, nhenti//'.Fille', max(51,nbenti-50),nbenti)
 334       endif
 335 #endif
 336 c
 337       endif
 338 c
 339 c====
 340 c 6. la fin
 341 c====
 342 c
 343       if ( codret.ne.0 ) then
 344 c
 345 #include "envex2.h"
 346       write (ulsort,texte(langue,1)) 'Sortie', nompro
 347       write (ulsort,texte(langue,2)) codret
 348 c
 349       endif
 350 c
 351 #ifdef _DEBUG_HOMARD_
 352       write (ulsort,texte(langue,1)) 'Sortie', nompro
 353       call dmflsh (iaux)
 354 #endif
 355 c
 356       end