src/tool/Decision/deinse.F

   1       subroutine deinse ( typenh,
   2      >                    seuihe, seuibe,
   3      >                    pilraf, pilder,
   4      >                    typseh, typseb, seuilh, seuilb, nbsoci,
   5      >                    indtab, tabind,
   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 traitement des DEcisions - INitialisation des SEuils
  28 c                --          --                 --
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . typenh . e   .   1    . type d'entites concernees                  .
  34 c .        .     .        . -1 : noeuds                                .
  35 c .        .     .        . 1 : aretes                                 .
  36 c .        .     .        . 2 : triangles                              .
  37 c .        .     .        . 3 : tetraedres                             .
  38 c .        .     .        . 4 : quadrangles                            .
  39 c .        .     .        . 5 : pyramides                              .
  40 c .        .     .        . 6 : hexaedres                              .
  41 c .        .     .        . 7 : pentaedres                             .
  42 c . seuihe .  s  .   1    . borne superieure absolue de l'erreur entite.
  43 c . seuibe .  s  .   1    . borne inferieure absolue de l'erreur entite.
  44 c . pilraf . e   .   1    . pilotage du raffinement                    .
  45 c .        .     .        . -1 : raffinement uniforme                  .
  46 c .        .     .        .  0 : pas de raffinement                    .
  47 c .        .     .        .  1 : raffinement libre                     .
  48 c .        .     .        .  2 : raff. libre homogene en type d'element.
  49 c . pilder . e   .   1    . pilotage du deraffinement                  .
  50 c .        .     .        . 0 : pas de deraffinement                   .
  51 c .        .     .        . 1 : deraffinement libre                    .
  52 c .        .     .        . -1 : deraffinement uniforme                .
  53 c . typseh . e   .   1    . type de seuil haut                         .
  54 c .        .     .        . 1 : absolu                                 .
  55 c .        .     .        . 2 : relatif                                .
  56 c .        .     .        . 3 : pourcentage d'entites                  .
  57 c .        .     .        . 4 : moyenne + nh*ecart-type                .
  58 c .        .     .        . 5 : cible en nombre de noeuds              .
  59 c . typseb . e   .   1    . type de seuil bas                          .
  60 c .        .     .        . 1 : absolu                                 .
  61 c .        .     .        . 2 : relatif                                .
  62 c .        .     .        . 3 : pourcentage d'entites                  .
  63 c .        .     .        . 4 : moyenne - nb*ecart-type                .
  64 c . seuilh . e   .   1    . borne superieure de l'erreur (absolue,     .
  65 c .        .     .        . relatif, pourcentage d'entites ou nh)      .
  66 c . seuilb . e   .   1    . borne inferieure de l'erreur (absolue,     .
  67 c .        .     .        . relatif, pourcentage d'entites ou nb)      .
  68 c . nbsoci . e   .   1    . cible en nombre de sommets  (-1 si non)    .
  69 c . indtab . e   .   1    . dernier indice affecte dans tabind         .
  70 c . tabind . e   . indtab . tableau de l'indicateur                    .
  71 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  72 c . langue . e   .    1   . langue des messages                        .
  73 c .        .     .        . 1 : francais, 2 : anglais                  .
  74 c . codret . es  .    1   . code de retour des modules                 .
  75 c .        .     .        . 0 : pas de probleme                        .
  76 c .        .     .        . 4 : nombres d'entites incoherents          .
  77 c .        .     .        . 2 : probleme dans le traitement            .
  78 c .        .     .        . 3 : les seuils sont mal definis            .
  79 c .        .     .        . 5 : mauvaise cible                         .
  80 c ______________________________________________________________________
  81 c
  82 c====
  83 c 0. declarations et dimensionnement
  84 c====
  85 c
  86 c 0.1. ==> generalites
  87 c
  88       implicit none
  89       save
  90 c
  91       character*6 nompro
  92       parameter ( nompro = 'DEINSE' )
  93 c
  94 #include "nblang.h"
  95 c
  96 c 0.2. ==> communs
  97 c
  98 #include "envex1.h"
  99 c
 100 #include "envada.h"
 101 c
 102 #include "gmenti.h"
 103 #include "infini.h"
 104 #include "precis.h"
 105 #include "impr02.h"
 106 #include "nombno.h"
 107 #include "envca1.h"
 108 c
 109 c 0.3. ==> arguments
 110 c
 111       integer typenh
 112       integer pilraf, pilder
 113       integer typseh, typseb
 114       integer nbsoci
 115       integer indtab
 116 c
 117       integer ulsort, langue, codret
 118 c
 119       double precision seuibe, seuihe
 120       double precision seuilb, seuilh
 121       double precision tabind(indtab)
 122 c
 123 c 0.4. ==> variables locales
 124 c
 125       integer iaux
 126 cgn      integer jaux
 127       integer ptrav1
 128       integer codre0
 129 c
 130       double precision vmin, vmax
 131       double precision vmoy, sigma
 132       double precision daux
 133 c
 134       character*8 ntrav1
 135 cgn      character*8 saux08
 136 cgn      character*80 repere
 137 c
 138       logical lgaux1, lgaux2, lgaux3
 139 c
 140       integer nbmess
 141       parameter (nbmess = 16 )
 142       character*80 texte(nblang,nbmess)
 143 c ______________________________________________________________________
 144 c
 145 c====
 146 c 1. initialisation
 147 c====
 148 c
 149 #include "impr01.h"
 150 c
 151 #ifdef _DEBUG_HOMARD_
 152       write (ulsort,texte(langue,1)) 'Entree', nompro
 153       call dmflsh (iaux)
 154 #endif
 155 c
 156 #include "impr03.h"
 157 c
 158 cgn      write (ulsort,90002) 'typenh', typenh
 159 cgn      write (ulsort,90002) 'pilraf', pilraf
 160 cgn      write (ulsort,90002) 'pilder', pilder
 161 cgn      write (ulsort,90002) 'typseh', typseh
 162 cgn      write (ulsort,90004) 'seuilh', seuilh
 163 cgn      write (ulsort,90002) 'typseb', typseb
 164 cgn      write (ulsort,90004) 'seuilb', seuilb
 165 cgn 1400 format(5(i5,' : ',i11,' |'))
 166 cgn 1401 format(5(i5,' : ',g11.4,' |'))
 167 c
 168       texte(1,4) = '(''Le seuil haut n''''est pas defini.'')'
 169       texte(1,5) = '(''Le seuil bas n''''est pas defini.'')'
 170       texte(1,6) = '(''Entite '',i10)'
 171       texte(1,7) = '(''. Nombre d''''entites actives :'',i10)'
 172       texte(1,8) =
 173      >'(''. Nombre d''''entites designees par le support :'',i10)'
 174       texte(1,9) = '(5x,a14,'' : seuil haut ='',g13.5,/)'
 175       texte(1,10) = '(5x,a14,'' : seuil bas  ='',g13.5,/)'
 176       texte(1,11) = '(''Recherche des seuils pour les '',a))'
 177       texte(1,12) = '(''On prend la valeur brute de l''''indicateur.'')'
 178       texte(1,13) =
 179      > '(''On prend la valeur absolue de l''''indicateur.'')'
 180       texte(1,14) = '(''Nombre de sommets actuel :'',i10)'
 181       texte(1,15) = '(''Nombre de sommets voulu  :'',i10)'
 182       texte(1,16) = '(''Impossible'')'
 183 c
 184       texte(2,4) = '(''Upper threshold is not defined.'')'
 185       texte(2,5) = '(''Lower threshold is not defined.'')'
 186       texte(2,6) = '(''Entity '',i10)'
 187       texte(2,7) = '(''. Number of active entities :'',i10)'
 188       texte(2,8) =
 189      >'(''. Number of entities declared by support of error :'',i10)'
 190       texte(2,9) = '(5x,a14,'': Upper threshold ='',g13.5,/)'
 191       texte(2,10) = '(5x,a14,'': Lower threshold ='',g13.5,/)'
 192       texte(2,11) = '(''Thresholds for the '',a))'
 193       texte(2,12) = '(''Inlet value for indicator is taken.'')'
 194       texte(2,13) = '(''Absolute value for indicator is taken.'')'
 195       texte(2,14) = '(''Number of vertices          :'',i10)'
 196       texte(2,15) = '(''Targetted number of vertices:'',i10)'
 197       texte(2,16) = '(''Impossible'')'
 198 c
 199 c====
 200 c 2. Prealables
 201 c====
 202 c 2.1. ==> Controles
 203 c
 204 #ifdef _DEBUG_HOMARD_
 205       write (ulsort,90002) 'typseh', typseh
 206       write (ulsort,90002) 'typseb', typseb
 207 #endif
 208 c
 209       if ( pilraf.gt.0 .and. typseh.eq.0 .and. nbsoci.le.0 ) then
 210         write (ulsort,texte(langue,4))
 211         codret = 3
 212       endif
 213 c
 214       if ( nbiter.gt.0 ) then
 215 c
 216         if ( pilder.gt.0 .and. typseb.eq.0 ) then
 217           write (ulsort,texte(langue,5))
 218           codret = 3
 219         endif
 220 c
 221       endif
 222 c 2.2. ==> Par defaut, on prend des valeurs extremes inhibant toute
 223 c          adaptation
 224 c
 225       seuihe = vinfpo
 226       seuibe = vinfne
 227 c
 228 c 2.3. ==> Pour une cible, on va estimer un pourcentage de mailles
 229 c 2.3.1. ==> Au premier passage, on va estimer un pourcentage de mailles
 230 c
 231       if ( typseh.eq.5 ) then
 232 c
 233 #ifdef _DEBUG_HOMARD_
 234         write (ulsort,texte(langue,14)) nbnop1
 235         write (ulsort,texte(langue,15)) nbsoci
 236 #endif
 237 c
 238         if ( nbsoci.lt.nbnop1 ) then
 239           write (ulsort,texte(langue,14)) nbnop1
 240           write (ulsort,texte(langue,15)) nbsoci
 241           write (ulsort,texte(langue,16))
 242           codret = 5
 243         endif
 244 c
 245         if ( codret.eq.0 ) then
 246 c
 247         daux = dble(nbsoci)/dble(nbnop1)
 248 cgn        write (ulsort,90004) 'nbsoci/nbnop1', daux
 249 c
 250         daux = daux - 1.d0
 251         if ( mdim.eq.1 ) then
 252           daux = daux
 253         elseif ( mdim.eq.2 ) then
 254           daux = daux/2.d0
 255         else
 256           daux = daux/4.d0
 257         endif
 258 cgn        write (ulsort,90004) 'daux', daux
 259         seuilh = 100.d0 * daux
 260         seuilh = min(seuilh, 100.d0)
 261 #ifdef _DEBUG_HOMARD_
 262         write (ulsort,90004) 'seuilh', seuilh
 263 #endif
 264 c
 265         endif
 266 c
 267       endif
 268 c
 269 c 2.3.2. ==> Ensuite, on transfere
 270 c
 271       if ( codret.eq.0 ) then
 272 c
 273       if ( ( typseh.eq.0 ) .and. (nbsoci.gt.0 ) ) then
 274 c
 275         seuihe = seuilh
 276 c
 277       endif
 278 c
 279       endif
 280 c
 281 #ifdef _DEBUG_HOMARD_
 282       write (ulsort,texte(langue,11)) mess14(langue,3,typenh)
 283 #endif
 284 c
 285 c====
 286 c 3. si les seuils sont definis par des valeurs absolues
 287 c====
 288 c
 289 #ifdef _DEBUG_HOMARD_
 290       write (ulsort,90002) '3. seuils en valeur absolue ; codret',codret
 291 #endif
 292 c
 293       if ( codret.eq.0 ) then
 294 c
 295       if ( pilraf.gt.0 .and. typseh.eq.1 ) then
 296         seuihe = seuilh
 297       endif
 298 c
 299       if ( pilder.gt.0 .and. typseb.eq.1 ) then
 300         seuibe = seuilb
 301       endif
 302 c
 303       endif
 304 c
 305 c====
 306 c 4. determination des seuils si :
 307 c    . un des seuils est fourni en relatif
 308 c    . un des seuils est fourni en pourcentage d'entites
 309 c    . un des seuils est fourni en mu+n.sigma
 310 c    . un nombre de noeuds cibles est recherche
 311 c====
 312 c
 313 #ifdef _DEBUG_HOMARD_
 314       write (ulsort,90002) '4. determination des seuils ; codret',codret
 315 #endif
 316 c
 317       if ( ( pilraf.gt.0 .and. typseh.ge.2 .and. typseh.le.5 ) .or.
 318      >     ( pilder.gt.0 .and. typseb.ge.2 .and. typseb.le.4 ) ) then
 319 c
 320 c 4.1. ==> allocation du tableau de travail pour uttris
 321 c
 322         if ( codret.eq.0 ) then
 323 c
 324 #ifdef _DEBUG_HOMARD_
 325       write (ulsort,90015) 'Allocation pour',
 326      >                     indtab, ' '//mess14(langue,3,typenh)
 327 #endif
 328 c
 329         call gmalot ( ntrav1, 'entier  ', indtab, ptrav1, codre0 )
 330 c
 331         codret = max ( abs(codre0), codret )
 332 c
 333         endif
 334 c
 335 c 4.2. ==> tri
 336 c          On a besoin de la valeur max dans les cas suivants :
 337 c              - raffinement ou deraffinement libre, seuil exprime
 338 c                en relatif et valant plus de 0%
 339 c              - raffinement libre, seuil exprime en pourcentage
 340 c                d'elements et valant moins de 0%
 341 c              - deraffinement libre, seuil exprime en pourcentage
 342 c                d'elements et valant plus de 100%
 343 c          On a besoin de la valeur min dans les cas suivants :
 344 c              - raffinement ou deraffinement libre, seuil exprime
 345 c                en relatif et valant moins de 100%
 346 c              - raffinement libre, seuil exprime en pourcentage
 347 c                d'elements et valant plus de 100%
 348 c              - deraffinement libre, seuil exprime en pourcentage
 349 c                d'elements et valant moins de 0%
 350 c          On a besoin de la valeur moy et de l'ecart-type dans les
 351 c          cas suivants :
 352 c              - raffinement ou deraffinement libre, seuil exprime
 353 c                en moyenne + coeff*(ecart-type)
 354 c
 355 c   lgaux1 = calcul de la valeur minimale
 356 c   lgaux2 = calcul de la valeur maximale
 357 c   lgaux3 = calcul de la valeur moyenne et de l'ecart-type
 358 c
 359         if ( codret.eq.0 ) then
 360 c
 361         lgaux1 = .false.
 362         lgaux2 = .false.
 363         lgaux3 = .false.
 364 c
 365 c 4.2.1. ==> examen du raffinement
 366 c
 367         if ( pilraf.gt.0 ) then
 368 c
 369 #ifdef _DEBUG_HOMARD_
 370       write (ulsort,93030) '4.2.1. Examen du raffinement'
 371 #endif
 372 c         relatif
 373           if ( typseh.eq.2 ) then
 374             if ( abs(seuilh).le.epsima ) then
 375               lgaux1 = .true.
 376             elseif ( abs(seuilh-100.d0).le.epsima ) then
 377               lgaux2 = .true.
 378             else
 379               lgaux1 = .true.
 380               lgaux2 = .true.
 381             endif
 382 c         pourcentage d'entites
 383           elseif ( typseh.eq.3 .or. typseh.eq.5 ) then
 384             if ( abs(seuilh).le.epsima ) then
 385               lgaux2 = .true.
 386             elseif ( abs(seuilh-100.d0).le.epsima ) then
 387               lgaux1 = .true.
 388             else
 389               lgaux1 = .true.
 390               lgaux2 = .true.
 391             endif
 392           elseif ( typseh.eq.4 ) then
 393             lgaux3 = .true.
 394           endif
 395 c
 396         endif
 397 c
 398 c 4.2.2. ==> examen du deraffinement
 399 c
 400         if ( pilder.gt.0 ) then
 401 c
 402 #ifdef _DEBUG_HOMARD_
 403       write (ulsort,93030) '4.2.2. Examen du deraffinement'
 404 #endif
 405 c         relatif
 406           if ( typseb.eq.2 ) then
 407             if ( abs(seuilb).le.epsima ) then
 408               lgaux1 = .true.
 409             elseif ( abs(seuilb-100.d0).le.epsima ) then
 410               lgaux2 = .true.
 411             else
 412               lgaux1 = .true.
 413               lgaux2 = .true.
 414             endif
 415 c         pourcentage d'entites
 416           elseif ( typseb.eq.3 ) then
 417             if ( abs(seuilb).le.epsima ) then
 418               lgaux1 = .true.
 419             elseif ( abs(seuilb-100.d0).le.epsima ) then
 420               lgaux2 = .true.
 421             else
 422               lgaux1 = .true.
 423               lgaux2 = .true.
 424             endif
 425           elseif ( typseb.eq.4 ) then
 426             lgaux3 = .true.
 427           endif
 428 c
 429         endif
 430 #ifdef _DEBUG_HOMARD_
 431       write (ulsort,99001) 'lgaux1', lgaux1
 432       write (ulsort,99001) 'lgaux2', lgaux2
 433       write (ulsort,99001) 'lgaux3', lgaux3
 434 #endif
 435 c
 436         endif
 437 c
 438 c 4.3. ==> Calcul
 439 c
 440         if ( codret.eq.0 ) then
 441 c
 442 c 4.3.1. ==> Mini/maxi
 443 c
 444         if ( lgaux1 .or. lgaux2 ) then
 445 c
 446 #ifdef _DEBUG_HOMARD_
 447       write (ulsort,93030) '4.3.1. Mini/maxi'
 448 #endif
 449 c
 450           vmin = vinfpo
 451           vmax = vinfne
 452           if ( lgaux1 .and. lgaux2 ) then
 453             do 4311 , iaux = 1, indtab
 454               vmin = min(vmin,tabind(iaux))
 455               vmax = max(vmax,tabind(iaux))
 456  4311       continue
 457           elseif ( lgaux2 ) then
 458             do 4312 , iaux = 1, indtab
 459               vmax = max(vmax,tabind(iaux))
 460  4312       continue
 461           else
 462             do 4313 , iaux = 1, indtab
 463               vmin = min(vmin,tabind(iaux))
 464  4313       continue
 465           endif
 466 #ifdef _DEBUG_HOMARD_
 467       write (ulsort,90004) 'vmin', vmin
 468       write (ulsort,90004) 'vmax', vmax
 469 #endif
 470 c
 471 c 4.3.2. ==> Moyenne et ecart-type
 472 c
 473         elseif ( lgaux3 ) then
 474 c
 475 #ifdef _DEBUG_HOMARD_
 476       write (ulsort,93030) '4.3.2. Moyenne et ecart-type'
 477 #endif
 478 c
 479           vmoy = 0.d0
 480           daux = 0.d0
 481           do 432 , iaux = 1, indtab
 482             vmoy = vmoy + tabind(iaux)
 483             daux = daux + tabind(iaux)**2
 484   432     continue
 485           vmoy = vmoy/dble(indtab)
 486           daux = daux/dble(indtab)
 487           sigma = sqrt(daux - vmoy**2)
 488 #ifdef _DEBUG_HOMARD_
 489           write(ulsort,90004) 'vmoy ', vmoy
 490           write(ulsort,90004) 'sigma', sigma
 491 #endif
 492 c
 493         endif
 494 c
 495         endif
 496 c
 497 c 4.4. ==> Deduction des seuils si exprime en pourcentage d'entites
 498 c 4.4.1. ==> si le seuil haut est exprime en pourcentage d'entites,
 499 c            strictement compris entre 0 et 100, on repere la valeur
 500 c            de seuil
 501 c
 502         if ( codret.eq.0 ) then
 503 c
 504         if ( pilraf.gt.0 .and.
 505      >       ( typseh.eq.3 .or. typseh.eq.5 ) ) then
 506 c
 507           if (        abs(seuilh).gt.epsima .and.
 508      >         abs(seuilh-100.d0).gt.epsima ) then
 509 c
 510 cgn      write (ulsort,1401)(iaux,tabind(iaux),iaux=1,indtab)
 511             iaux = 1
 512 #ifdef _DEBUG_HOMARD_
 513       write (ulsort,texte(langue,3)) 'UTTRIS', nompro
 514 #endif
 515             call uttris ( seuihe,
 516      >                    iaux, imem(ptrav1),
 517      >                    seuilh, indtab, tabind,
 518      >                    ulsort, langue, codret )
 519 c
 520 cgn      codre0 = nint(seuilh*dble(indtab)/100.d0)
 521 cgn      if ( indtab.ge.2 ) codre0 = min(codre0+1,indtab)
 522 cgn      write (ulsort,*) '================== ptrav1 ========='
 523 cgn      write (ulsort,1400) (iaux,imem(ptrav1+iaux-1),iaux=1,codre0)
 524 cgn      write (ulsort,*) '=================='
 525 cgn      write (ulsort,*) '=========== ptrav1 trie pour haut ========'
 526 cgn      write (ulsort,1401)
 527 cgn     >(iaux,tabind(imem(ptrav1+iaux-1)),iaux=1,codre0)
 528 cgn      write (ulsort,90004) '==> seuihe',seuihe
 529           endif
 530 c
 531         endif
 532 c
 533         endif
 534 c
 535 c 4.4.2. ==> si le seuil bas est exprime en pourcentage d'entites,
 536 c            strictement compris entre 0 et 100, on repere la valeur
 537 c            de seuil
 538 c
 539         if ( codret.eq.0 ) then
 540 c
 541         if ( pilder.gt.0 .and. typseh.eq.3 ) then
 542 c
 543           if (        abs(seuilh).gt.epsima .and.
 544      >         abs(seuilh-100.d0).gt.epsima ) then
 545 c
 546             iaux = 2
 547 #ifdef _DEBUG_HOMARD_
 548       write (ulsort,texte(langue,3)) 'UTTRIS', nompro
 549 #endif
 550             call uttris ( seuibe,
 551      >                    iaux, imem(ptrav1),
 552      >                    seuilb, indtab , tabind,
 553      >                    ulsort, langue, codret )
 554 c
 555 cgn      codre0 = nint(seuilb*dble(indtab)/100.d0)
 556 cgn      if ( indtab.ge.2 ) codre0 = min(codre0+1,indtab)
 557 cgn      write (ulsort,*) '================== ptrav1 ========='
 558 cgn      write (ulsort,1400) (iaux,imem(ptrav1+iaux-1),iaux=1,codre0)
 559 cgn      write (ulsort,*) '=================='
 560 cgn      write (ulsort,*) '=========== ptrav1 trie pour bas ========'
 561 cgn      write (ulsort,1401)
 562 cgn     >(iaux,tabind(imem(ptrav1+iaux-1)),iaux=1,codre0)
 563 cgn      write (ulsort,90004) '==> seuibe',seuibe
 564           endif
 565 c
 566         endif
 567 c
 568         endif
 569 c
 570 c 4.5. ==> Les seuils definitifs
 571 c
 572         if ( codret.eq.0 ) then
 573 c
 574 c 4.5.1. ==> en raffinement
 575 c
 576         if ( pilraf.gt.0 ) then
 577 c
 578 #ifdef _DEBUG_HOMARD_
 579       write (ulsort,93030) '4.5.1. Seuil en raffinement'
 580 #endif
 581 c
 582 c       relatif
 583         if ( typseh.eq.2 ) then
 584           if ( abs(vmax-vmin).le.epsima ) then
 585             seuihe = vmax + epsima
 586           elseif ( abs(seuilh).le.epsima ) then
 587             seuihe = 0.999d0*vmin
 588           elseif ( abs(seuilh-100.d0).le.epsima ) then
 589             seuihe = 1.5d0*vmax
 590           else
 591             seuihe = vmin + seuilh*(vmax-vmin)/100.d0
 592           endif
 593 c       pourcentage d'entites
 594         elseif ( typseh.eq.3 .or. typseh.eq.5 ) then
 595           if ( abs(vmax-vmin).le.epsima ) then
 596             seuihe = vmax + epsima
 597           elseif ( abs(seuilh).le.epsima ) then
 598             seuihe = 1.5d0*vmax
 599           elseif ( abs(seuilh-100.d0).le.epsima ) then
 600             seuihe = 0.999d0*vmin
 601           endif
 602 c       moyenne et ecart-type
 603         elseif ( typseh.eq.4 ) then
 604           if ( abs(sigma).le.epsima ) then
 605             seuihe = vmoy + epsima
 606           else
 607             seuihe = vmoy + seuilh*sigma
 608           endif
 609         endif
 610 c
 611         endif
 612 c
 613 c 4.5.2. ==> en deraffinement
 614 c
 615         if ( pilder.gt.0 ) then
 616 c
 617 #ifdef _DEBUG_HOMARD_
 618       write (ulsort,93030) '4.5.2. Seuil en deraffinement'
 619 #endif
 620 c
 621 c       relatif
 622         if ( typseb.eq.2 ) then
 623           if ( abs(vmax-vmin).le.epsima ) then
 624             seuibe = vmin - epsima
 625           elseif ( abs(seuilb).le.epsima ) then
 626             seuibe = 0.999d0*vmin
 627           elseif ( abs(seuilb-100.d0).le.epsima ) then
 628             seuibe = 1.5d0*vmax
 629           else
 630             seuibe = vmin + seuilb*(vmax-vmin)/100.d0
 631           endif
 632 c       pourcentage d'entites
 633         elseif ( typseb.eq.3 ) then
 634           if ( abs(vmax-vmin).le.epsima ) then
 635             seuibe = vmin - epsima
 636           elseif ( abs(seuilb).le.epsima ) then
 637             seuibe = 0.999d0*vmin
 638           elseif ( abs(seuilb-100.d0).le.epsima ) then
 639             seuibe = 1.5d0*vmax
 640           endif
 641 c       moyenne et ecart-type
 642         elseif ( typseh.eq.4 ) then
 643           if ( abs(sigma).le.epsima ) then
 644             seuibe = vmoy - epsima
 645           else
 646             seuibe = vmoy - seuilb*sigma
 647           endif
 648         endif
 649 c
 650         endif
 651 c
 652         endif
 653 c
 654 c 4.6. ==> liberation des tableaux temporaires
 655 c
 656         if ( codret.eq.0 ) then
 657 c
 658         call gmlboj ( ntrav1 , codre0 )
 659 c
 660         codret = max ( abs(codre0), codret )
 661 c
 662         endif
 663 c
 664       endif
 665 c
 666 c====
 667 c 5. Ecriture sur la sortie standard et sur le fichier recapitulatif
 668 c====
 669 c
 670 #ifdef _DEBUG_HOMARD_
 671       write (ulsort,90002) '5. Ecriture standard ; codret',codret
 672 #endif
 673 c
 674       if ( pilraf.gt.0 .and.
 675      >     ( ( typseh.ge.1 .and. typseh.le.5 ) .or.
 676      >       ( typseh.eq.0 .and. nbsoci.gt.0 ) ) ) then
 677 c
 678         if ( codret.eq.0 ) then
 679 c
 680         write (ulsort,texte(langue,9)) mess14(langue,4,typenh), seuihe
 681 c
 682 cgn        iaux = 2
 683 cgn        jaux = 25
 684 cgnc                         12345678901
 685 cgn        repere(1:jaux) = 'Seuil haut '//mess14(langue,4,typenh)
 686 cgn#ifdef _DEBUG_HOMARD_
 687 cgn      write (ulsort,texte(langue,3)) 'UTSYNT', nompro
 688 cgn#endif
 689 cgn        call utsynt ( repere, jaux,
 690 cgn     >                iaux, jaux, seuihe, saux08, jaux,
 691 cgn     >                ulsort, langue, codret )
 692 c
 693         endif
 694 c
 695       endif
 696 c
 697       if ( nbiter.gt.0 ) then
 698 c
 699       if ( pilder.gt.0 .and. typseb.ge.1 .and. typseb.le.4 ) then
 700 c
 701         if ( codret.eq.0 ) then
 702 c
 703         write (ulsort,texte(langue,10)) mess14(langue,4,typenh), seuibe
 704 c
 705 cgn        iaux = 2
 706 cgn        jaux = 24
 707 cgnc                         1234567890
 708 cgn        repere(1:jaux) = 'Seuil bas '//mess14(langue,4,typenh)
 709 cgn#ifdef _DEBUG_HOMARD_
 710 cgn      write (ulsort,texte(langue,3)) 'UTSYNT', nompro
 711 cgn#endif
 712 cgn        call utsynt ( repere, jaux,
 713 cgn     >                iaux, jaux, seuibe, saux08, jaux,
 714 cgn     >                ulsort, langue, codret )
 715 c
 716         endif
 717 c
 718         endif
 719 c
 720       endif
 721       if ( typseh.eq.5 ) then
 722         typseh = 0
 723       endif
 724 c
 725 #ifdef _DEBUG_HOMARD_
 726       write (ulsort,90004) '==> seuihe', seuihe
 727       write (ulsort,90004) '==> seuibe', seuibe
 728 #endif
 729 c
 730 c====
 731 c 6. la fin
 732 c====
 733 c
 734       if ( codret.ne.0 ) then
 735 c
 736 #include "envex2.h"
 737 c
 738       write (ulsort,texte(langue,1)) 'Sortie', nompro
 739       write (ulsort,texte(langue,2)) codret
 740 c
 741       endif
 742 c
 743 #ifdef _DEBUG_HOMARD_
 744       write (ulsort,texte(langue,1)) 'Sortie', nompro
 745       call dmflsh (iaux)
 746 #endif
 747 c
 748       end