src/tool/Decision/deiucm.F

   1       subroutine deiucm ( 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 - Usage des CoMposantes
  25 c                --          -                 -         - -
  26 c ______________________________________________________________________
  27 c .        .     .        .                                            .
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . nohind . e   .  ch8   . nom de l'objet contenant l'indicateur      .
  31 c . lgopti . e   .   1    . longueur du tableau des options            .
  32 c . taopti . e   . lgopti . tableau des options                        .
  33 c . lgetco . e   .   1    . longueur du tableau de l'etat courant      .
  34 c . taetco . e   . lgetco . tableau de l'etat courant                  .
  35 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  36 c . langue . e   .    1   . langue des messages                        .
  37 c .        .     .        . 1 : francais, 2 : anglais                  .
  38 c . codret . es  .    1   . code de retour des modules                 .
  39 c .        .     .        . 0 : pas de probleme                        .
  40 c ______________________________________________________________________
  41 c
  42 c====
  43 c 0. declarations et dimensionnement
  44 c====
  45 c
  46 c 0.1. ==> generalites
  47 c
  48       implicit none
  49       save
  50 c
  51       character*6 nompro
  52       parameter ( nompro = 'DEIUCM' )
  53 c
  54 #include "nblang.h"
  55 c
  56 c 0.2. ==> communs
  57 c
  58 #include "envex1.h"
  59 c
  60 #include "gmenti.h"
  61 #include "gmreel.h"
  62 c
  63 #include "impr02.h"
  64 c
  65 c 0.3. ==> arguments
  66 c
  67       character*8 nohind
  68 c
  69       integer lgopti
  70       integer taopti(lgopti)
  71 c
  72       integer lgetco
  73       integer taetco(lgetco)
  74 c
  75       integer ulsort, langue, codret
  76 c
  77 c 0.4. ==> variables locales
  78 c
  79       integer codava
  80       integer nrosec
  81       integer nretap, nrsset
  82       integer iaux
  83 c
  84       integer adnoin, adnorn, adnosu
  85       integer adarin, adarrn, adarsu
  86       integer adtrin, adtrrn, adtrsu
  87       integer adquin, adqurn, adqusu
  88       integer adtein, adtern, adtesu
  89       integer adhein, adhern, adhesu
  90       integer adpyin, adpyrn, adpysu
  91       integer adpein, adpern, adpesu
  92       integer nbvnoe, nbvare
  93       integer nbvtri, nbvqua
  94       integer nbvtet, nbvhex, nbvpyr, nbvpen
  95 c
  96       integer usacmp
  97       integer typind, ncmpin
  98       integer nbvent(-1:7)
  99       integer adsupp(-1:7)
 100       integer advale(-1:7)
 101 c
 102       character*6 saux
 103 c
 104 #ifdef _DEBUG_HOMARD_
 105       character*7 saux07(nblang,2)
 106 #endif
 107 c
 108       integer nbmess
 109       parameter ( nbmess = 15 )
 110       character*80 texte(nblang,nbmess)
 111 c
 112 c 0.5. ==> initialisations
 113 c ______________________________________________________________________
 114 c
 115 c====
 116 c 1. messages
 117 c====
 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       codava = codret
 127 c
 128 c=======================================================================
 129       if ( codava.eq.0 ) then
 130 c=======================================================================
 131 c
 132 c 1.1. ==> le debut des mesures de temps
 133 c
 134       nrosec = taetco(4)
 135       call gtdems (nrosec)
 136 c
 137 c 1.3. ==> les messages
 138 c
 139       texte(1,4) =
 140      > '(/,a6,'' USAGE DES COMPOSANTES'')'
 141       texte(1,5) = '(28(''=''),/)'
 142       texte(1,6) = '(''Le champ d''''indicateur est '',a)'
 143       texte(1,7) = '(''Nombre de composantes :'',i3)'
 144       texte(1,8) = '(''Nombre de valeurs pour les '',a,'':'',i10)'
 145       texte(1,9) = '(''. Norme L2 des composantes.'')'
 146       texte(1,10) = '(''. Norme infinie des composantes.'')'
 147       texte(1,11) = '(''. Valeur relative de la composante.'')'
 148 c
 149       texte(2,4) =
 150      > '(/,a6,'' USE OF THE COMPONENTS'')'
 151       texte(2,5) = '(28(''=''),/)'
 152       texte(2,6) = '(''The type of the indicator is '',a)'
 153       texte(2,7) = '(''Number of components:'',i3)'
 154       texte(2,8) = '(''Number of values for the '',a,'':'',i10)'
 155       texte(2,9) = '(''. L2 norm of components.'')'
 156       texte(2,10) = '(''. Infinite norm of components.'')'
 157       texte(2,11) = '(''. Relative value for the component.'')'
 158 c
 159 c 1.4. ==> le numero de sous-etape
 160 c
 161       nretap = taetco(1)
 162       nrsset = taetco(2) + 1
 163       taetco(2) = nrsset
 164 c
 165       call utcvne ( nretap, nrsset, saux, iaux, codret )
 166 c
 167 c 1.5. ==> le titre
 168 c
 169       write (ulsort,texte(langue,4)) saux
 170       write (ulsort,texte(langue,5))
 171 c
 172 c====
 173 c 2. gestion des tableaux
 174 c====
 175 c
 176 c 2.1. ==> structure generale de l'indicateur
 177 c
 178       if ( codret.eq.0 ) then
 179 c
 180 #ifdef _DEBUG_HOMARD_
 181       write (ulsort,texte(langue,3)) 'DEINI0', nompro
 182 #endif
 183       call deini0 ( nohind, typind, ncmpin,
 184      >              nbvnoe, nbvare,
 185      >              nbvtri, nbvqua,
 186      >              nbvtet, nbvhex, nbvpyr, nbvpen,
 187      >              adnoin, adnorn, adnosu,
 188      >              adarin, adarrn, adarsu,
 189      >              adtrin, adtrrn, adtrsu,
 190      >              adquin, adqurn, adqusu,
 191      >              adtein, adtern, adtesu,
 192      >              adhein, adhern, adhesu,
 193      >              adpyin, adpyrn, adpysu,
 194      >              adpein, adpern, adpesu,
 195      >              ulsort, langue, codret )
 196 c
 197       endif
 198 c
 199       if ( codret.eq.0 ) then
 200 c
 201       nbvent(-1) = nbvnoe
 202       nbvent(0)  = 0
 203       nbvent(1)  = nbvare
 204       nbvent(2)  = nbvtri
 205       nbvent(4)  = nbvqua
 206       nbvent(3)  = nbvtet
 207       nbvent(5)  = nbvpyr
 208       nbvent(6)  = nbvhex
 209       nbvent(7)  = nbvpen
 210 c
 211       adsupp(-1) = adnosu
 212       adsupp(1)  = adarsu
 213       adsupp(2)  = adtrsu
 214       adsupp(4)  = adqusu
 215       adsupp(3)  = adtesu
 216       adsupp(5)  = adpysu
 217       adsupp(6)  = adhesu
 218       adsupp(7)  = adpesu
 219 c
 220       advale(-1) = adnorn
 221       advale(1)  = adarrn
 222       advale(2)  = adtrrn
 223       advale(4)  = adqurn
 224       advale(3)  = adtern
 225       advale(5)  = adpyrn
 226       advale(6)  = adhern
 227       advale(7)  = adpern
 228 c
 229 #ifdef _DEBUG_HOMARD_
 230       saux07(1,1) = 'entier '
 231       saux07(1,2) = 'reel   '
 232       saux07(2,1) = 'integer'
 233       saux07(2,2) = 'real   '
 234       write (ulsort,texte(langue,6)) saux07(langue,typind-1)
 235       write (ulsort,texte(langue,7)) ncmpin
 236       do 222 , iaux= -1, 7
 237       write (ulsort,texte(langue,8)) mess14(langue,3,iaux), nbvent(iaux)
 238   222 continue
 239 #endif
 240 c
 241       endif
 242 c
 243 c====
 244 c 3. Calcul par type d'entite
 245 c====
 246 #ifdef _DEBUG_HOMARD_
 247       write (ulsort,*) '3. Calcul par type entite ; codret = ', codret
 248 #endif
 249 c
 250 c 3.1. ==> Si une seule composante et si valeur relative, rien n'est
 251 c          a faire, sinon traitement
 252 c
 253       usacmp = taopti(8)
 254 #ifdef _DEBUG_HOMARD_
 255       write (ulsort,texte(langue,9+usacmp))
 256 #endif
 257       if ( usacmp.eq.2 .and. ncmpin.eq.1 ) then
 258         goto 39
 259       endif
 260 c
 261 c 3.2. ==> traitement
 262 cgn      call gmprsx(nompro,nohind//'.Arete.ValeursR')
 263 c
 264       do 30 , iaux = -1, 7
 265 c
 266         if ( nbvent(iaux).gt.0 ) then
 267 c
 268           if ( codret.eq.0 ) then
 269 c
 270 #ifdef _DEBUG_HOMARD_
 271       write (ulsort,texte(langue,3)) 'DEIUC0', nompro
 272 #endif
 273           call deiuc0 ( nbvent(iaux), ncmpin, usacmp,
 274      >                  imem(adsupp(iaux)), rmem(advale(iaux)),
 275      >                  ulsort, langue, codret)
 276 c
 277           endif
 278 c
 279         endif
 280 c
 281    30 continue
 282 c
 283    39 continue
 284 cgn      call gmprsx(nompro,nohind//'.Arete.ValeursR')
 285 c
 286 c====
 287 c 4. Bilan
 288 c====
 289 #ifdef _DEBUG_HOMARD_
 290       write (ulsort,*) '4. Bilan ; codret = ', codret
 291 #endif
 292 c
 293       if ( codret.eq.0 ) then
 294 c
 295 #ifdef _DEBUG_HOMARD_
 296       write (ulsort,texte(langue,3)) 'DEIUC0', nompro
 297 #endif
 298       call deinbi ( nbvent, ncmpin,
 299      >              imem(adnosu), rmem(adnorn),
 300      >              imem(adarsu), rmem(adarrn),
 301      >              imem(adtrsu), rmem(adtrrn),
 302      >              imem(adqusu), rmem(adqurn),
 303      >              imem(adtesu), rmem(adtern),
 304      >              imem(adhesu), rmem(adhern),
 305      >              imem(adpysu), rmem(adpyrn),
 306      >              imem(adpesu), rmem(adpern),
 307      >              ulsort, langue, codret)
 308 c
 309       endif
 310 c
 311 c====
 312 c 5. la fin
 313 c====
 314 c
 315 c 5.1. ==> message si erreur
 316 c
 317       if ( codret.ne.0 ) then
 318 c
 319 #include "envex2.h"
 320 c
 321       write (ulsort,texte(langue,1)) 'Sortie', nompro
 322       write (ulsort,texte(langue,2)) codret
 323 c
 324       endif
 325 c
 326 c 5.2. ==> fin des mesures de temps de la section
 327 c
 328       call gtfims (nrosec)
 329 c
 330 #ifdef _DEBUG_HOMARD_
 331       write (ulsort,texte(langue,1)) 'Sortie', nompro
 332       call dmflsh (iaux)
 333 #endif
 334 c
 335 c=======================================================================
 336       endif
 337 c=======================================================================
 338 c
 339       end