src/tool/Utilitaire/utmmco.F

   1       subroutine utmmco ( xyzmin, xyzmax, xyzeps,
   2      >                    nbnoto, sdim, coonoe,
   3      >                    ulsort, langue, codret )
   4 c ______________________________________________________________________
   5 c
   6 c                             H O M A R D
   7 c
   8 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   9 c
  10 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  11 c aupres des huissiers de justice Simart et Lavoir a Clamart
  12 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  13 c aupres des huissiers de justice
  14 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  15 c
  16 c    HOMARD est une marque deposee d'Electricite de France
  17 c
  18 c Copyright EDF 1996
  19 c Copyright EDF 1998
  20 c Copyright EDF 2002
  21 c Copyright EDF 2020
  22 c ______________________________________________________________________
  23 c
  24 c    UTilitaire - Minimum/Maximum des COordonnees
  25 c    --           -       -           --
  26 c ______________________________________________________________________
  27 c .        .     .        .                                            .
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . xyzmin .  s  .    3   . abscisse (i=1), ordonnee (i=2) et          .
  31 c .        .     .        . cote (i=3) minimales du domaine total      .
  32 c . xyzmax .  s  .    3   . abscisse (i=1), ordonnee (i=2) et          .
  33 c .        .     .        . cote (i=3) maximales du domaine total      .
  34 c . xyzeps .  s  .    4   . -1 si min = max dans la direction,         .
  35 c .        .     .        . ecart sinon, puis ecart maximal            .
  36 c . nbnoto . e   .   1    . nombre total de noeuds                     .
  37 c . sdim   . e   .   1    . dimension                                  .
  38 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  39 c .        .     . * sdim .                                            .
  40 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  41 c . langue . e   .    1   . langue des messages                        .
  42 c .        .     .        . 1 : francais, 2 : anglais                  .
  43 c . codret . es  .    1   . code de retour des modules                 .
  44 c .        .     .        . 0 : pas de probleme                        .
  45 c ______________________________________________________________________
  46 c
  47 c====
  48 c 0. declarations et dimensionnement
  49 c====
  50 c
  51 c 0.1. ==> generalites
  52 c
  53       implicit none
  54       save
  55 c
  56       character*6 nompro
  57       parameter ( nompro = 'UTMMCO' )
  58 c
  59 #include "nblang.h"
  60 c
  61 c 0.2. ==> communs
  62 c
  63 #include "envex1.h"
  64 c
  65 c 0.3. ==> arguments
  66 c
  67       integer nbnoto, sdim
  68 c
  69       double precision coonoe (nbnoto,sdim)
  70       double precision xyzmin(3), xyzmax(3), xyzeps(4)
  71 c
  72       integer ulsort, langue, codret
  73 c
  74 c 0.4. ==> variables locales
  75 c
  76       integer iaux, jaux
  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) = '(''Nombre de noeuds : '',i10)'
  97       texte(1,5) = '(''Dimension        : '',i8)'
  98       texte(1,6) =
  99      > '(''direction *  minimum   *  maximum   *   ecart'',/,50(''*''))'
 100       texte(1,7) =
 101      > '(50(''*''),/,''Taille maximale :'',g12.5,/,50(''*''))'
 102 c
 103       texte(2,4) = '(''Number of nodes : '',i10)'
 104       texte(2,5) = '(''Dimension       : '',i8)'
 105       texte(2,6) =
 106      > '(''direction *  minimum   *  maximum   *   shift'',/,50(''*''))'
 107       texte(2,7) =
 108      > '(50(''*''),/,''Maximum size :'',g12.5,/,50(''*''))'
 109 c
 110  1000 format(5x,a1,4x,3('*',g12.5))
 111 c
 112 #ifdef _DEBUG_HOMARD_
 113       write (ulsort,texte(langue,4)) nbnoto
 114       write (ulsort,texte(langue,5)) sdim
 115 #endif
 116 c
 117       codret = 0
 118 c
 119 c====
 120 c 2. min/max des coordonnees et tolerance
 121 c====
 122 c 2.1. ==> Mise a zero de la 3eme dimension eventuellement absente
 123 c
 124       do 21 , iaux = sdim+1 , 3
 125         xyzmin(iaux) = 0.d0
 126         xyzmax(iaux) = 0.d0
 127    21 continue
 128 c
 129 c 2.2. ==> Recherche des extremes
 130 c
 131       xyzeps(4) = 0.d0
 132       do 22 , iaux = 1 , sdim
 133 c
 134         xyzmin(iaux) = coonoe(1,iaux)
 135         xyzmax(iaux) = coonoe(1,iaux)
 136         do 220 , jaux = 2 , nbnoto
 137           xyzmin(iaux) = min ( xyzmin(iaux), coonoe(jaux,iaux) )
 138           xyzmax(iaux) = max ( xyzmax(iaux), coonoe(jaux,iaux) )
 139   220   continue
 140         xyzeps(iaux) = xyzmax(iaux) - xyzmin(iaux)
 141         xyzeps(4) = max ( xyzeps(4), xyzeps(iaux) )
 142 c
 143    22 continue
 144 c
 145 c 2.3. ==> Notation des coordonnees constantes
 146 c    Si pour une coordonnee, l'ecart entre le min et le max
 147 c    est 1 million de fois plus petit que le max des ecarts,
 148 c    c'est que le probleme est vraisemblablement plan dans cette
 149 c    direction. On memorise cela en mettant une tolerance negative.
 150 c    Sinon, on memorise l'ecart min/max.
 151 c    Ces valeurs sont totalement pifometriques.
 152 c
 153       do 23 , iaux = 1 , 3
 154         if ( xyzeps(iaux)/xyzeps(4).lt.1.d-6 ) then
 155           xyzeps(iaux) = -1.d0
 156         endif
 157    23 continue
 158 c
 159 #ifdef _DEBUG_HOMARD_
 160       if ( codret.eq.0 ) then
 161       write (ulsort,texte(langue,6))
 162       write (ulsort,1000) 'x', xyzmin(1), xyzmax(1), xyzeps(1)
 163       write (ulsort,1000) 'y', xyzmin(2), xyzmax(2), xyzeps(2)
 164       if ( sdim.eq.3 ) then
 165         write (ulsort,1000) 'z', xyzmin(3), xyzmax(3), xyzeps(3)
 166       endif
 167       write (ulsort,texte(langue,7)) xyzeps(4)
 168       endif
 169 #endif
 170 c
 171 c====
 172 c 3. la fin
 173 c====
 174 c
 175       if ( codret.ne.0 ) then
 176 c
 177 #include "envex2.h"
 178 c
 179       write (ulsort,texte(langue,1)) 'Sortie', nompro
 180       write (ulsort,texte(langue,2)) codret
 181 c
 182       endif
 183 c
 184 #ifdef _DEBUG_HOMARD_
 185       write (ulsort,texte(langue,1)) 'Sortie', nompro
 186       call dmflsh (iaux)
 187 #endif
 188 c
 189       end