src/tool/Decision/deisau.F

   1       subroutine deisau ( nomail, nohind,
   2      >                    lgopti, taopti, lgetco, taetco,
   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 traitement des DEcisions - Initialisations - SAUt
  25 c                --          -                 ---
  26 c ______________________________________________________________________
  27 c .        .     .        .                                            .
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . nomail . e   .  ch8   . nom de l'objet contenant le maillage       .
  31 c . nohind . e   .  ch8   . nom de l'objet contenant l'indicateur      .
  32 c . lgopti . e   .   1    . longueur du tableau des options            .
  33 c . taopti . e   . lgopti . tableau des options                        .
  34 c . lgetco . e   .   1    . longueur du tableau de l'etat courant      .
  35 c . taetco . e   . lgetco . tableau de l'etat courant                  .
  36 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  37 c . langue . e   .    1   . langue des messages                        .
  38 c .        .     .        . 1 : francais, 2 : anglais                  .
  39 c . codret . es  .    1   . code de retour des modules                 .
  40 c .        .     .        . 0 : pas de probleme                        .
  41 c ______________________________________________________________________
  42 c
  43 c====
  44 c 0. declarations et dimensionnement
  45 c====
  46 c
  47 c 0.1. ==> generalites
  48 c
  49       implicit none
  50       save
  51 c
  52       character*6 nompro
  53       parameter ( nompro = 'DEISAU' )
  54 c
  55 #include "nblang.h"
  56 c
  57 c 0.2. ==> communs
  58 c
  59 #include "envex1.h"
  60 #include "enti01.h"
  61 c
  62 #include "gmenti.h"
  63 #include "gmreel.h"
  64 c
  65 #include "nombar.h"
  66 #include "envca1.h"
  67 #include "impr02.h"
  68 c
  69 c 0.3. ==> arguments
  70 c
  71       character*8 nomail, nohind
  72 c
  73       integer lgopti
  74       integer taopti(lgopti)
  75 c
  76       integer lgetco
  77       integer taetco(lgetco)
  78 c
  79       integer ulsort, langue, codret
  80 c
  81 c 0.4. ==> variables locales
  82 c
  83       integer codava
  84       integer nrosec
  85       integer nretap, nrsset
  86       integer iaux
  87 c
  88       integer adnoin, adnorn, adnosu
  89       integer adarin, adarrn, adarsu
  90       integer adtrin, adtrrn, adtrsu
  91       integer adquin, adqurn, adqusu
  92       integer adtein, adtern, adtesu
  93       integer adhein, adhern, adhesu
  94       integer adpyin, adpyrn, adpysu
  95       integer adpein, adpern, adpesu
  96       integer nbvnoe, nbvare
  97       integer nbvtri, nbvqua
  98       integer nbvtet, nbvhex, nbvpyr, nbvpen
  99 c
 100       integer typind, ncmpin
 101       integer nbvent(-1:7)
 102 c
 103       character*6 saux
 104       character*8 motaux
 105       character*8 norenu
 106       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 107       character*8 nhtetr, nhhexa, nhpyra, nhpent
 108       character*8 nhelig
 109       character*8 nhvois, nhsupe, nhsups
 110       character*14 saux14
 111 c
 112 #ifdef _DEBUG_HOMARD_
 113       character*7 saux07(nblang,2)
 114 #endif
 115 c
 116       logical afaire
 117 c
 118       integer nbmess
 119       parameter ( nbmess = 10 )
 120       character*80 texte(nblang,nbmess)
 121 c
 122 c 0.5. ==> initialisations
 123 c
 124       data motaux / 'ValeursR' /
 125 c ______________________________________________________________________
 126 c
 127 c====
 128 c 1. messages
 129 c====
 130 c
 131 #include "impr01.h"
 132 c
 133 #ifdef _DEBUG_HOMARD_
 134       write (ulsort,texte(langue,1)) 'Entree', nompro
 135       call dmflsh (iaux)
 136 #endif
 137 c
 138 #include "impr03.h"
 139 c
 140       codava = codret
 141 c
 142 c=======================================================================
 143       if ( codava.eq.0 ) then
 144 c=======================================================================
 145 c
 146 c 1.1. ==> le debut des mesures de temps
 147 c
 148       nrosec = taetco(4)
 149       call gtdems (nrosec)
 150 c
 151 c 1.3. ==> les messages
 152 c
 153       texte(1,4) =
 154      > '(/,a6,'' CALCUL DES SAUTS'')'
 155       texte(1,5) = '(23(''=''),/)'
 156       texte(1,6) = '(''Le champ d''''indicateur est '',a)'
 157       texte(1,7) = '(''Nombre de composantes :'',i3)'
 158       texte(1,8) = '(''Nombre de valeurs pour les '',a,'':'',i10)'
 159 c
 160       texte(2,4) =
 161      > '(/,a6,'' CALCULATIONS OF THE JUMPS'')'
 162       texte(2,5) = '(32(''=''),/)'
 163       texte(2,6) = '(''The type of the indicator is '',a)'
 164       texte(2,7) = '(''Number of components:'',i3)'
 165       texte(2,8) = '(''Number of values for the '',a,'':'',i10)'
 166 c
 167 c 1.4. ==> le numero de sous-etape
 168 c
 169       nretap = taetco(1)
 170       nrsset = taetco(2) + 1
 171       taetco(2) = nrsset
 172 c
 173       call utcvne ( nretap, nrsset, saux, iaux, codret )
 174 c
 175 c 1.5. ==> le titre
 176 c
 177       write (ulsort,texte(langue,4)) saux
 178       write (ulsort,texte(langue,5))
 179 c
 180 c====
 181 c 2. gestion des tableaux
 182 c====
 183 c
 184 c 2.1. ==> structure generale
 185 c
 186       if ( codret.eq.0 ) then
 187 c
 188 #ifdef _DEBUG_HOMARD_
 189       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 190 #endif
 191       call utnomh ( nomail,
 192      >                sdim,   mdim,
 193      >               degre, maconf, homolo, hierar,
 194      >              rafdef, nbmane, typcca, typsfr, maextr,
 195      >              mailet,
 196      >              norenu,
 197      >              nhnoeu, nhmapo, nharet,
 198      >              nhtria, nhquad,
 199      >              nhtetr, nhhexa, nhpyra, nhpent,
 200      >              nhelig,
 201      >              nhvois, nhsupe, nhsups,
 202      >              ulsort, langue, codret)
 203 c
 204       endif
 205 c
 206 c 2.2. ==> structure generale de l'indicateur
 207 c
 208       if ( codret.eq.0 ) then
 209 c
 210 #ifdef _DEBUG_HOMARD_
 211       write (ulsort,texte(langue,3)) 'DEINI0', nompro
 212 #endif
 213       call deini0 ( nohind, typind, ncmpin,
 214      >              nbvnoe, nbvare,
 215      >              nbvtri, nbvqua,
 216      >              nbvtet, nbvhex, nbvpyr, nbvpen,
 217      >              adnoin, adnorn, adnosu,
 218      >              adarin, adarrn, adarsu,
 219      >              adtrin, adtrrn, adtrsu,
 220      >              adquin, adqurn, adqusu,
 221      >              adtein, adtern, adtesu,
 222      >              adhein, adhern, adhesu,
 223      >              adpyin, adpyrn, adpysu,
 224      >              adpein, adpern, adpesu,
 225      >              ulsort, langue, codret )
 226 c
 227       endif
 228 c
 229       if ( codret.eq.0 ) then
 230 c
 231       nbvent(-1) = nbvnoe
 232       nbvent(0)  = 0
 233       nbvent(1)  = nbvare
 234       nbvent(2)  = nbvtri
 235       nbvent(4)  = nbvqua
 236       nbvent(3)  = nbvtet
 237       nbvent(5)  = nbvpyr
 238       nbvent(6)  = nbvhex
 239       nbvent(7)  = nbvpen
 240 c
 241       afaire = .false.
 242       do 21 , iaux= -1, 7
 243        if ( nbvent(iaux).gt.0 ) then
 244          afaire = .true.
 245         endif
 246    21 continue
 247 c
 248 #ifdef _DEBUG_HOMARD_
 249       saux07(1,1) = 'entier '
 250       saux07(1,2) = 'reel   '
 251       saux07(2,1) = 'integer'
 252       saux07(2,2) = 'real   '
 253       write (ulsort,texte(langue,6)) saux07(langue,typind-1)
 254       write (ulsort,texte(langue,7)) ncmpin
 255       do 222 , iaux= -1, 7
 256       write (ulsort,texte(langue,8)) mess14(langue,3,iaux), nbvent(iaux)
 257   222 continue
 258 #endif
 259 c
 260       endif
 261 c
 262 c====
 263 c 3. Si l'indicateur est fourni par noeud, on alloue la branche
 264 c    par arete ... sauf si elle existe, ce qui ne devrait pas arriver !
 265 c====
 266 #ifdef _DEBUG_HOMARD_
 267       write (ulsort,90002) '3. allocation ; codret', codret
 268 #endif
 269 c
 270       if ( nbvent(-1).gt.0 ) then
 271 c
 272       if ( codret.eq.0 ) then
 273 c
 274         if ( nbvent(1).gt.0 ) then
 275 c
 276           codret = 31
 277 c
 278         else
 279 c
 280 #ifdef _DEBUG_HOMARD_
 281       write (ulsort,texte(langue,3)) 'UTALIH_ar', nompro
 282 #endif
 283           iaux = 1
 284           call utalih ( nohind, iaux, nbarto, ncmpin, motaux,
 285      >                  adarrn, adarsu,
 286      >                  ulsort, langue, codret)
 287           nbvent(iaux) = nbarac
 288 c
 289         endif
 290 c
 291       endif
 292 c
 293       endif
 294 c
 295 c====
 296 c 4. calcul des sauts
 297 c====
 298 #ifdef _DEBUG_HOMARD_
 299       write (ulsort,90002) '4. calcul des sauts ; codret', codret
 300 #endif
 301 c
 302       if ( afaire ) then
 303 c
 304         if ( codret.eq.0 ) then
 305 c
 306 #ifdef _DEBUG_HOMARD_
 307       write (ulsort,texte(langue,3)) 'DEISA1', nompro
 308 #endif
 309         call deisa1 ( nbvent, ncmpin, taopti( 8),
 310      >                imem(adnosu), rmem(adnorn),
 311      >                imem(adarsu), rmem(adarrn),
 312      >                imem(adtrsu), rmem(adtrrn),
 313      >                imem(adqusu), rmem(adqurn),
 314      >                imem(adtesu), rmem(adtern),
 315      >                imem(adhesu), rmem(adhern),
 316      >                imem(adpysu), rmem(adpyrn),
 317      >                imem(adpesu), rmem(adpern),
 318      >                nharet, nhtria, nhquad,
 319      >                nhtetr, nhhexa, nhpyra, nhpent,
 320      >                nomail, nhvois,
 321      >                ulsort, langue, codret)
 322 c
 323         endif
 324 c
 325       endif
 326 c
 327 c====
 328 c 5. Si l'indicateur est fourni par noeud, menage
 329 c====
 330 #ifdef _DEBUG_HOMARD_
 331       write (ulsort,90002) '5. menage ; codret', codret
 332 #endif
 333 c
 334       if ( codret.eq.0 ) then
 335 c
 336       if ( nbvent(-1).gt.0 ) then
 337 c
 338         saux14 = nohind//'.'//suffix(1,-1)(1:5)
 339         call gmsgoj ( saux14 , codret )
 340         nbvent(-1) = 0
 341 c
 342       endif
 343 c
 344       endif
 345 c
 346 c====
 347 c 6. la fin
 348 c====
 349 c
 350 c 6.1. ==> message si erreur
 351 c
 352       if ( codret.ne.0 ) then
 353 c
 354 #include "envex2.h"
 355 c
 356       write (ulsort,texte(langue,1)) 'Sortie', nompro
 357       write (ulsort,texte(langue,2)) codret
 358 c
 359       endif
 360 c
 361 c 6.2. ==> fin des mesures de temps de la section
 362 c
 363       call gtfims (nrosec)
 364 c
 365 #ifdef _DEBUG_HOMARD_
 366       write (ulsort,texte(langue,1)) 'Sortie', nompro
 367       call dmflsh (iaux)
 368 #endif
 369 c
 370 c=======================================================================
 371       endif
 372 c=======================================================================
 373 c
 374       end