src/tool/Utilitaire/utnc03.F

   1       subroutine utnc03 ( option, nbanci, numfin,
   2      >                    arreca, arrecb,
   3      >                    somare, filare, merare,
   4      >                    ngenar, nouare, tabaux,
   5      >                    ulsort, langue, codret )
   6 c ______________________________________________________________________
   7 c
   8 c                             H O M A R D
   9 c
  10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  11 c
  12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  13 c aupres des huissiers de justice Simart et Lavoir a Clamart
  14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  15 c aupres des huissiers de justice
  16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  17 c
  18 c    HOMARD est une marque deposee d'Electricite de France
  19 c
  20 c Copyright EDF 1996
  21 c Copyright EDF 1998
  22 c Copyright EDF 2002
  23 c Copyright EDF 2020
  24 c ______________________________________________________________________
  25 c
  26 c    UTilitaire - Non Conformite - phase 03
  27 c    --           -   -                  --
  28 c    On change les numeros des aretes concernees par les non-conformites
  29 c    On les regroupe par generations, en commencant par celle sans mere
  30 c    puis celle avec mere, puis celle avec une mere et une grand-mere,
  31 c    et ainsi de suite.
  32 c    On regroupe ensuite les fratries.
  33 c    Enfin, on etablit la bonne convention de numerotation des aretes
  34 c    dans une fratrie
  35 c ______________________________________________________________________
  36 c .        .     .        .                                            .
  37 c .  nom   . e/s . taille .           description                      .
  38 c .____________________________________________________________________.
  39 c . option . e   .    1   . option de l'operation de renumerotation    .
  40 c .        .     .        .  0 : dans chaque fratrie, on classe les    .
  41 c .        .     .        .      aretes                                .
  42 c .        .     .        . -n : decalage des aretes ayant une         .
  43 c .        .     .        .      ascendance de n generations           .
  44 c .        .     .        .  n : on regroupe par fratries les aretes   .
  45 c .        .     .        .      ayant une  ascendance de n generations.
  46 c . nbanci . e   .    1   . nombre d'aretes de non conformite initiale .
  47 c .        .     .        . egal au nombre d'aretes recouvrant 2 autres.
  48 c . numfin . es  .    1   . numero d'ordre maximal pour le classement  .
  49 c . arreca . e   .2*nbanci. liste des aretes recouvrant une autre      .
  50 c . arrecb . e   .2*nbanci. liste des aretes recouvertes par une autre .
  51 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  52 c . filare . e   . nbarto . premiere fille des aretes                  .
  53 c . merare . e   . nbarto . mere des aretes                            .
  54 c . ngenar . e   . nbarto . nombre de generations au-dessus des aretes .
  55 c . nouare .  s  .0:nbarto. nouveau numero des aretes                  .
  56 c . tabaux . a   .3*nbanci. tableau auxiliaire                         .
  57 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  58 c . langue . e   .    1   . langue des messages                        .
  59 c .        .     .        . 1 : francais, 2 : anglais                  .
  60 c . codret . es  .    1   . code de retour des modules                 .
  61 c .        .     .        . 0 : pas de probleme                        .
  62 c .        .     .        . -1 : mauvaise option                       .
  63 c .        .     .        . >0 : erreur dans le traitement de l'option .
  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 = 'UTNC03' )
  77 c
  78 #include "nblang.h"
  79 c
  80 c 0.2. ==> communs
  81 c
  82 #include "impr02.h"
  83 #include "envex1.h"
  84 c
  85 #include "nombar.h"
  86 c
  87 c 0.3. ==> arguments
  88 c
  89       integer option
  90       integer nbanci
  91       integer numfin
  92       integer arreca(2*nbanci), arrecb(2*nbanci)
  93       integer somare(2,nbarto)
  94       integer filare(nbarto), merare(nbarto)
  95       integer ngenar(nbarto), nouare(0:nbarto)
  96       integer tabaux(3,nbanci)
  97 c
  98       integer ulsort, langue, codret
  99 c
 100 c 0.4. ==> variables locales
 101 c
 102       integer iaux, jaux, kaux
 103       integer numgen, ifin
 104       integer laret1, laret2, laretg
 105 c
 106       integer nbmess
 107       parameter ( nbmess = 20 )
 108       character*80 texte(nblang,nbmess)
 109 c
 110 c 0.5. ==> initialisations
 111 c ______________________________________________________________________
 112 c
 113 c====
 114 c 1. preliminaires
 115 c====
 116 c
 117 c 1.1. ==> messages
 118 c
 119 #include "impr01.h"
 120 c
 121 #ifdef _DEBUG_HOMARD_
 122       write (ulsort,texte(langue,1)) 'Entree', nompro
 123       call dmflsh (iaux)
 124 #endif
 125 c
 126       texte(1,4) = '(''Nombre de non-conformites :'',i10))'
 127       texte(1,5) = '(''Traitement numero'',i3))'
 128       texte(1,6) =
 129      > '(''Mise en coherence des '',a,''dans les fratries de '',a)'
 130       texte(1,7) = '(''Decalage des '',a,'' de generation'',i3)'
 131       texte(1,8) = '(''Regroupement des '',a,'' de generation'',i3)'
 132       texte(1,9) = '(''Classement avant'',i10)'
 133       texte(1,10) = '(i10,1x,a,''dans la generation'',i10)'
 134       texte(1,11) = '(''Nouveau numero du '',a,i10,'' : '',i10)'
 135       texte(1,12) = '(''Il devrait etre '',a,i10)'
 136       texte(1,18) = '(''Generation du '',a,i10,'' :'',i4)'
 137       texte(1,19) = '(''Examen du '',a,i10)'
 138       texte(1,20) = '(''.. couvert par le '',a,i10)'
 139 c
 140       texte(2,4) = '(''Number of non-conformal situations :'',i10))'
 141       texte(2,5) = '(''Treatment #'',i3)'
 142       texte(2,6) =
 143      > '(''Coherence of '',a,''in brotherhood of '',a)'
 144       texte(2,7) = '(''Renumbering of '',a,'' in generation'',i3)'
 145       texte(2,8) = '(''Gathering of '',a,'' in generation'',i3)'
 146       texte(2,9) = '(''Sort before'',i10)'
 147       texte(2,10) = '(i10,1x,a,''in generation'',i10)'
 148       texte(2,11) = '(''New # for '',a,i10,'' : '',i10)'
 149       texte(2,12) = '(''It should be '',a,i10)'
 150       texte(2,18) = '(''Generation of '',a,i10,'' :'',i4)'
 151       texte(2,19) = '(''Examination of '',a,'' #'',i10)'
 152       texte(2,20) = '(''.. covered by '',a,'' #'',i10)'
 153 c
 154 c 1.2. ==> initialisation
 155 c
 156       codret = 0
 157 c
 158       if ( option.lt.0 ) then
 159         numgen = -option
 160       elseif ( option.gt.0 ) then
 161         numgen = option
 162       endif
 163 c
 164 #ifdef _DEBUG_HOMARD_
 165       write (ulsort,texte(langue,4)) nbanci
 166 #endif
 167 #ifdef _DEBUG_HOMARD_
 168       write (ulsort,texte(langue,5)) option
 169       if ( option.eq.0 ) then
 170         write (ulsort,texte(langue,6)) mess14(langue,3,-1),
 171      >                                 mess14(langue,3,1)
 172       else
 173         if ( option.lt.0 ) then
 174           write (ulsort,texte(langue,7)) mess14(langue,3,1), numgen
 175           write (ulsort,texte(langue,9)) numfin
 176         else
 177           write (ulsort,texte(langue,8)) mess14(langue,3,1), numgen
 178         endif
 179       endif
 180 #endif
 181 c
 182 c 1.3. ==> Aucune renumerotation au depart
 183 c
 184       do 12 , iaux = 0 , nbarto
 185         nouare(iaux) = iaux
 186    12 continue
 187 c
 188 c====
 189 c 2. option < 0 : on rassemble les aretes de meme generation
 190 c    on les deplace vers la fin, en prenant soin de ne pas ecraser
 191 c    les generations plus jeunes (d'ou le demarrage a ifin)
 192 c====
 193 c
 194       if ( option.lt.0 ) then
 195 c
 196         ifin = numfin
 197 c
 198         do 21 , iaux = 1 , nbarto
 199 c
 200           if ( codret.eq.0 ) then
 201 c
 202           if ( ngenar(iaux).eq.numgen .and. iaux.le.ifin ) then
 203 c
 204 #ifdef _DEBUG_HOMARD_
 205             write (ulsort,texte(langue,19)) mess14(langue,1,1), iaux
 206 #endif
 207             do 211 , jaux = ifin, 1, -1
 208               if ( jaux.eq.iaux ) then
 209                 goto 212
 210               elseif ( ngenar(jaux).lt.numgen ) then
 211                 nouare(jaux) = iaux
 212                 nouare(iaux) = jaux
 213                 ifin = jaux - 1
 214 #ifdef _DEBUG_HOMARD_
 215                 write (ulsort,texte(langue,19)) mess14(langue,1,1),iaux
 216                 write (ulsort,*) iaux,' devient', jaux
 217 #endif
 218                 goto 212
 219               endif
 220   211       continue
 221 c
 222             codret = option
 223 c
 224   212       continue
 225 c
 226             ifin = jaux - 1
 227             goto 21
 228 c
 229           endif
 230 c
 231           endif
 232 c
 233    21   continue
 234 c
 235 #ifdef _DEBUG_HOMARD_
 236         write (ulsort,texte(langue,10)) numfin-ifin,
 237      >                                  mess14(langue,3,1), numgen
 238 #endif
 239 c
 240         numfin = ifin
 241 c
 242 c====
 243 c 3. option > 0 : au sein d'une generation, les aretes sont regroupees
 244 c                 par fratries
 245 c====
 246 c
 247       elseif ( option.gt.0 ) then
 248 c
 249 c 3.1. ==> Regroupement des triplets de filles adoptives et de mere
 250 c 3.1.1. ==> Aucun regroupement au depart
 251 c
 252         do 31 , iaux = 1 , nbanci
 253 c
 254           tabaux(1,iaux) = 0
 255           tabaux(2,iaux) = 0
 256           tabaux(3,iaux) = 0
 257 c
 258    31   continue
 259 c
 260 c 3.2. ==> On regroupe les triplets de filles adoptives et de mere
 261 c          pour la generation de fille numgen
 262 c
 263         if ( codret.eq.0 ) then
 264 c
 265         kaux = 0
 266         ifin = 2*nbanci
 267         do 32 , iaux = 1 , ifin
 268 c
 269           if ( codret.eq.0 ) then
 270 c
 271           laret1 = arrecb(iaux)
 272 c
 273           if ( ngenar(laret1).eq.numgen ) then
 274 c
 275             laretg = arreca(iaux)
 276 c
 277 #ifdef _DEBUG_HOMARD_
 278           write (ulsort,texte(langue,19)) mess14(langue,1,1), laret1
 279           write (ulsort,texte(langue,20)) mess14(langue,1,1), laretg
 280 #endif
 281 c
 282 c       on cherche si on a deja place l'arete jumelle de laret1
 283 c       . si oui, on place l'arete courante en position 2
 284 c       . si non, on place l'arete courante en position 1 et on
 285 c         enregistre la mere adoptive
 286 c
 287             do 321 ,  jaux = 1, kaux
 288 c
 289               if ( tabaux(3,jaux).eq.laretg ) then
 290                 if ( ngenar(tabaux(1,jaux)).ne.numgen ) then
 291           write (ulsort,texte(langue,18)) mess14(langue,1,1),
 292      >                                    laret1, numgen
 293           write (ulsort,texte(langue,18)) mess14(langue,1,1),
 294      >                     tabaux(1,jaux), ngenar(tabaux(1,jaux))
 295           write (ulsort,texte(langue,20)) mess14(langue,1,1), laretg
 296                   codret = option
 297                 endif
 298                 tabaux(2,jaux) = laret1
 299                 goto 32
 300               endif
 301 c
 302   321       continue
 303 c
 304             kaux = kaux + 1
 305             tabaux(1,kaux) = laret1
 306             tabaux(3,kaux) = laretg
 307 c
 308           endif
 309 c
 310           endif
 311 c
 312    32   continue
 313 c
 314         endif
 315 c
 316 cgn        if ( codret.eq.0 ) then
 317 cgn        call utvars ( 1, 2, kaux, tabaux,
 318 cgn     >                somare,
 319 cgn     >                ulsort, langue, codret )
 320 cgn        write (ulsort,*) 'dans ',nompro,' ',1, 2,codret
 321 cgn        endif
 322 c
 323 cgn        if ( codret.eq.0 ) then
 324 cgn        call utvars ( 2, 3, kaux, tabaux,
 325 cgn     >                somare,
 326 cgn     >                ulsort, langue, codret )
 327 cgn        write (ulsort,*) 'dans ',nompro,' ',2,3,codret
 328 cgn        endif
 329 cc
 330 cgn        if ( codret.eq.0 ) then
 331 cgn        call utvars ( 3, 1, kaux, tabaux,
 332 cgn     >                somare,
 333 cgn     >                ulsort, langue, codret )
 334 cgn        write (ulsort,*) 'dans ',nompro,' ',3,1,codret
 335 cgn        endif
 336
 337 c 3.3. ==> Les places 1 et 2 de tabaux contiennent les 2 numeros actuels
 338 c          de 2 aretes soeurs, dans la generation numgen. Il y a kaux
 339 c          couples de ce genre.
 340 c          Ces aretes ont leurs numeros inferieurs a numfin.
 341 c          On va les placer 2 par 2 a partir de numfin, en descendant.
 342 c
 343         if ( codret.eq.0 ) then
 344 c
 345         ifin = numfin
 346 c
 347         do 33 , iaux = 1 , kaux
 348 c
 349           if ( codret.eq.0 ) then
 350 c
 351           laret1 = tabaux(1,iaux)
 352           laret2 = tabaux(2,iaux)
 353 c
 354 #ifdef _DEBUG_HOMARD_
 355 cgn      if (laret1.eq.15935)then
 356       write (ulsort,texte(langue,19)) mess14(langue,1,1), laret1
 357       write (ulsort,texte(langue,19)) mess14(langue,1,1), laret2
 358       write (ulsort,texte(langue,20)) mess14(langue,1,1), tabaux(3,iaux)
 359 cgn      endif
 360 #endif
 361 c
 362           nouare(laret1) = ifin
 363           nouare(laret2) = ifin - 1
 364 c
 365           ifin = ifin - 2
 366 c
 367           endif
 368 c
 369    33   continue
 370 c
 371 #ifdef _DEBUG_HOMARD_
 372         write (ulsort,texte(langue,10)) numfin-ifin,
 373      >                                  mess14(langue,3,1), numgen
 374 #endif
 375 c
 376         numfin = ifin
 377 cgn        write (ulsort,9999) (iaux, nouare(iaux),iaux=1,nbarto)
 378 cgn 9999 format('nouare(',i10,') = ',i10)
 379 c
 380         endif
 381 c
 382 c====
 383 c 5. option numero 0 : dans une fratrie, les soeurs sont rangees selon
 384 c    les numeros des sommets de l'arete mere (cf. cmrda1)
 385 c====
 386 c
 387       elseif ( option.eq.0 ) then
 388 c
 389         do 50 , iaux = 1 , nbarto
 390 c
 391 cgn      write (ulsort,*) 'arete ',iaux,' de fille ',filare(iaux)
 392           if ( filare(iaux).gt.0 ) then
 393 c
 394             laret1 = filare(iaux)
 395             laret2 = filare(iaux) + 1
 396 cgn      write (ulsort,*) '.. ',laret1, ' de ', somare(1,laret1),
 397 cgn     >' a ',somare(2,laret1),' de mere ',merare(laret1)
 398 cgn      write (ulsort,*) '.. ',laret2, ' de ', somare(1,laret2),
 399 cgn     >' a ',somare(2,laret2),' de mere ',merare(laret2)
 400 c
 401             if ( merare(laret2).eq.iaux ) then
 402 c
 403             if ( somare(1,laret1).gt.somare(1,laret2) ) then
 404 cgn      write (ulsort,*) 'echange des aretes ',laret1, ' et ', laret2
 405               nouare(laret1) = laret2
 406               nouare(laret2) = laret1
 407             endif
 408 c
 409             endif
 410 c
 411           endif
 412 c
 413    50   continue
 414 c
 415 c
 416 c====
 417 c 6. option autre : impossible
 418 c====
 419 c
 420       else
 421 c
 422         codret = -1
 423 c
 424       endif
 425 c
 426 c====
 427 c 7. la fin
 428 c====
 429 c
 430 cgn      write (ulsort,*) 'nouare :'
 431 cgn      write (ulsort,5555) (nouare(iaux),iaux=1,nbarto)
 432 cgn 5555 format(10i8)
 433 c
 434       if ( codret.ne.0 ) then
 435 c
 436 #include "envex2.h"
 437 c
 438       write (ulsort,texte(langue,1)) 'Sortie', nompro
 439       write (ulsort,texte(langue,2)) codret
 440 c
 441       endif
 442 c
 443 #ifdef _DEBUG_HOMARD_
 444       write (ulsort,texte(langue,1)) 'Sortie', nompro
 445       call dmflsh (iaux)
 446 #endif
 447 c
 448       end