src/tool/Decision/deinb1.F

   1       subroutine deinb1 ( typenh, nbento, ncmpin,
   2      >                    ensupp, enindi,
   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 - Bilan - etape 1
  25 c                --          --                -             -
  26 c but : impression des bilans de l'indicateur
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . typenh . e   .   1    . code des entites au sens homard            .
  32 c .        .     .        .   2 : triangles                            .
  33 c .        .     .        .   3 : tetraedres                           .
  34 c .        .     .        .   4 : quadrangles                          .
  35 c .        .     .        .   5 : pyramides                            .
  36 c .        .     .        .   6 : hexaedres                            .
  37 c .        .     .        .   7 : pentaedres                           .
  38 c . nbento . e   .   1    . nombre total d'entites                     .
  39 c . ncmpin .  e  .   1    . nombre de composantes de l'indicateur      .
  40 c . ensupp . e   . nbento . support pour les entites                   .
  41 c . enindi . e   . nbento . valeurs pour les entites                   .
  42 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  43 c . langue . e   .    1   . langue des messages                        .
  44 c .        .     .        . 1 : francais, 2 : anglais                  .
  45 c . codret . es  .    1   . code de retour des modules                 .
  46 c .        .     .        . 0 : pas de probleme                        .
  47 c .        .     .        . 3 : probleme dans les fichiers             .
  48 c ______________________________________________________________________
  49 c
  50 c====
  51 c 0. declarations et dimensionnement
  52 c====
  53 c
  54 c 0.1. ==> generalites
  55 c
  56       implicit none
  57       save
  58 c
  59       character*6 nompro
  60       parameter ( nompro = 'DEINB1' )
  61 c
  62 #include "nblang.h"
  63 c
  64 c 0.2. ==> communs
  65 c
  66 #include "envex1.h"
  67 c
  68 #include "gmreel.h"
  69 c
  70 #include "infini.h"
  71 #include "envada.h"
  72 #include "impr02.h"
  73 #include "enti01.h"
  74 c
  75 c 0.3. ==> arguments
  76 c
  77       integer typenh
  78       integer ncmpin
  79       integer nbento
  80       integer ensupp(nbento)
  81 c
  82       integer ulsort, langue, codret
  83 c
  84       double precision enindi(nbento,ncmpin)
  85 c
  86 c 0.4. ==> variables locales
  87 c
  88       integer nbclas
  89       parameter (nbclas=20)
  90 c
  91       integer histog(nbclas)
  92       integer iclass(0:nbclas)
  93       double precision rclass(0:nbclas)
  94 c
  95       character*8 ntrav1
  96       character*8 titcou(6)
  97       character*10 saux10
  98 c
  99       integer iaux, jaux
 100       integer ulhist, ulxmgr
 101       integer lnomfl
 102       integer ival(1), nbval
 103       integer adtra1
 104       integer codre1, codre2, codre3
 105       integer codre0
 106 #ifdef _DEBUG_HOMARD_
 107       integer ulbrut
 108 #endif
 109 c
 110       double precision valmin, valmax
 111       double precision vamiar, vamaar, valdif
 112       double precision xlow
 113 c
 114       logical consta
 115 c
 116       character*200 nomflo
 117 c
 118       integer nbmess
 119       parameter ( nbmess = 10 )
 120       character*80 texte(nblang,nbmess)
 121       character*54 mess54(nblang,nbmess)
 122 c
 123       character*8 mess08(nblang,2)
 124 c
 125 c 0.5. ==> initialisations
 126 c ______________________________________________________________________
 127 c
 128 c====
 129 c 1. initialisations
 130 c====
 131 c
 132 #include "impr01.h"
 133 c
 134 #ifdef _DEBUG_HOMARD_
 135       write (ulsort,texte(langue,1)) 'Entree', nompro
 136       call dmflsh (iaux)
 137 #endif
 138 c
 139       texte(1,4) =
 140      > '(''Impression du bilan de l''''indicateur sur les '',a)'
 141       texte(1,5) = '(''.. Valeur '',a,'' :'',g16.8)'
 142       texte(1,6) = '(''--> valeur arrondie pour le '',a,'' :'',g16.8)'
 143 c
 144       texte(2,4) =
 145      > '(''Printing of summary of indicator over '',a)'
 146       texte(2,5) = '(''.. Value '',a,'' :'',g16.8)'
 147       texte(2,6) = '(''--> round value for '',a,'' :'',g16.8)'
 148 c
 149 #include "impr03.h"
 150 c
 151 #ifdef _DEBUG_HOMARD_
 152       write (ulsort,texte(langue,4)) mess14(langue,3,typenh)
 153 #endif
 154 c
 155       codret = 0
 156 c
 157 c===
 158 c 2. tableaux de travail
 159 c===
 160 c 2.1. ==> Allocation
 161 c
 162       if ( codret.eq.0 ) then
 163 c
 164       call gmalot ( ntrav1, 'reel    ', nbento, adtra1, codre0 )
 165 c
 166       codret = max ( abs(codre0), codret )
 167 c
 168       endif
 169 c
 170 c 2.2. ==> Copie des valeurs filtrees
 171 c
 172       if ( codret.eq.0 ) then
 173 c
 174       nbval = 0
 175       do 22 , iaux = 1 , nbento
 176 c
 177         if ( ensupp(iaux).eq.1 ) then
 178           nbval = nbval + 1
 179           rmem(adtra1+nbval-1) = enindi(iaux,1)
 180           if ( nbval.eq.1 ) then
 181             valmin = enindi(iaux,1)
 182             valmax = enindi(iaux,1)
 183           else
 184             valmin = min (valmin,enindi(iaux,1))
 185             valmax = max (valmax,enindi(iaux,1))
 186           endif
 187         endif
 188 c
 189    22 continue
 190 c
 191 #ifdef _DEBUG_HOMARD_
 192       write (ulsort,texte(langue,5)) 'min', valmin
 193       write (ulsort,texte(langue,5)) 'max', valmax
 194 #endif
 195 c
 196       endif
 197 c
 198 c 2.3. ==> arrondis des valeurs extremes
 199 c
 200 #ifdef _DEBUG_HOMARD_
 201       write (ulsort,texte(langue,3)) 'UTARRO', nompro
 202 #endif
 203       call utarro ( valmin, valmax, vamiar, vamaar,
 204      >              ulsort, langue, codret )
 205 c
 206       if ( codret.eq.0 ) then
 207 c
 208 #ifdef _DEBUG_HOMARD_
 209       write (ulsort,texte(langue,6)) 'min', vamiar
 210       write (ulsort,texte(langue,6)) 'max', vamaar
 211 #endif
 212 c
 213       valdif = ( vamaar - vamiar ) * 1.05d0
 214       if ( valdif.le.zeroma ) then
 215         consta = .true.
 216       else
 217         consta = .false.
 218       endif
 219 #ifdef _DEBUG_HOMARD_
 220       write (ulsort,90004) 'valdif', valdif
 221       write (ulsort,99001) 'consta', consta
 222 #endif
 223 c
 224       endif
 225 c
 226 c====
 227 c 3. Ecriture des bilans
 228 c====
 229 #ifdef _DEBUG_HOMARD_
 230       write (ulsort,90002) '3. Ecriture des bilans ; codret', codret
 231 #endif
 232 c
 233 10100 format(/,5x,64('*'))
 234 10200 format(  5x,64('*'))
 235 11100 format(  5x,'*    ',a54,'    *')
 236 11200 format(  5x,'*',14x,2a8,i10,1x,a14,7x,'*')
 237 c
 238 c 3.1. ==> Les fichiers
 239 c 3.1.1. ==> Le fichier d'historique
 240 c
 241       if ( codret.eq.0 ) then
 242 c
 243 c               1234567890
 244       saux10 = 'indic.'//suffix(2,typenh)(1:4)
 245       iaux = 3
 246       jaux = -1
 247 #ifdef _DEBUG_HOMARD_
 248       write (ulsort,texte(langue,3)) 'UTULBI_hist', nompro
 249 #endif
 250       call utulbi ( ulhist, nomflo, lnomfl,
 251      >                iaux, saux10, nbiter, jaux,
 252      >              ulsort, langue, codret )
 253 c
 254       endif
 255 c
 256 c 3.1.2. ==> Le fichier pour xmgrace
 257 c
 258       if ( .not.consta ) then
 259 c
 260       if ( codret.eq.0 ) then
 261 c
 262       saux10 = 'indic.'//suffix(2,typenh)(1:4)
 263       iaux = 2
 264       jaux = -1
 265 #ifdef _DEBUG_HOMARD_
 266       write (ulsort,texte(langue,3)) 'UTULBI_xmgr', nompro
 267 #endif
 268       call utulbi ( ulxmgr, nomflo, lnomfl,
 269      >                iaux, saux10, nbiter, jaux,
 270      >              ulsort, langue, codret )
 271 c
 272       endif
 273 c
 274       endif
 275 c
 276 #ifdef _DEBUG_HOMARD_
 277 c
 278 c 3.1.3. ==> Le fichier des valeurs brutes
 279 c
 280       if ( codret.eq.0 ) then
 281 c
 282 c               1234   56                      7890
 283       saux10 = 'ind.'//suffix(4,typenh)(1:2)//'    '
 284       iaux = 10
 285       jaux = -1
 286       write (ulsort,texte(langue,3)) 'UTULBI_brut', nompro
 287       call utulbi ( ulbrut, nomflo, lnomfl,
 288      >                iaux, saux10, nbiter, jaux,
 289      >              ulsort, langue, codret )
 290 c
 291       endif
 292 #endif
 293 c
 294 c 3.2. ==> Les en-tetes
 295 c
 296       if ( codret.eq.0 ) then
 297 c
 298 c       123456789012345678901234567890123456789012345678901234'
 299       mess54(1,1) =
 300      > '             Champ pilotant l''adaptation              '
 301       mess54(1,2) =
 302      > '            Valeur constante :                        '
 303 c
 304       mess54(2,1) =
 305      > '            Governing field over the mesh             '
 306       mess54(2,2) =
 307      > '              Constant value :                        '
 308 c
 309       mess08(1,1) = 'Valeur s'
 310       mess08(1,2) = 'ur les  '
 311 c
 312       mess08(2,1) = 'Value ov'
 313       mess08(2,2) = 'er the  '
 314 c
 315       write (ulhist,10100)
 316       write (ulhist,11100) mess54(langue,1)
 317       write (ulhist,11200) mess08(langue,1), mess08(langue,2),
 318      >                     nbval, mess14(langue,3,typenh)
 319 c
 320       endif
 321 c
 322 c 3.3. ==> message si constant
 323 c
 324       if ( codret.eq.0 ) then
 325 c
 326       if ( consta ) then
 327 c
 328         write (ulhist,10200)
 329         write (mess54(langue,2)(32:42),'(f11.4)') valmin
 330         write (ulhist,11100) mess54(langue,2)
 331         write (ulhist,10200)
 332 c
 333       endif
 334 c
 335       endif
 336 c
 337 c 3.4. ==> Classement
 338 c
 339       if ( .not.consta ) then
 340 c
 341       if ( codret.eq.0 ) then
 342 c
 343       valdif = (vamaar-vamiar)/dble(nbclas)
 344       rclass(0) = vamiar
 345       do 34 , iaux = 1 , nbclas-1
 346         rclass(iaux) = vamiar + valdif*dble(iaux)
 347    34 continue
 348       rclass(nbclas) = vamaar
 349 #ifdef _DEBUG_HOMARD_
 350       write (ulsort,90004) 'valdif', valdif
 351       do 3434 , iaux = 0 , nbclas
 352         write (ulsort,90024) 'rclass', iaux, rclass(iaux)
 353  3434 continue
 354 #endif
 355 c
 356       endif
 357 c
 358       if ( codret.eq.0 ) then
 359 c
 360       titcou(1) = mess08(langue,1)
 361       titcou(2) = mess08(langue,2)(1:7)//mess14(langue,3,typenh)(1:1)
 362       titcou(3) = mess14(langue,3,typenh)(2:9)
 363       titcou(4) = mess14(langue,3,typenh)(10:14)//'   '
 364       titcou(5) = mess08(langue,1)(1:6)
 365       xlow = vamiar
 366       iaux = 2
 367 #ifdef _DEBUG_HOMARD_
 368       write (ulsort,texte(langue,3)) 'UTCRHI', nompro
 369 #endif
 370       call utcrhi ( nbclas, rclass, iclass, histog,
 371      >              nbval,  iaux,   rmem(adtra1), ival,
 372      >              titcou, xlow, ulhist, ulxmgr,
 373      >              ulsort, langue, codret )
 374 c
 375       endif
 376 c
 377       endif
 378 c
 379 #ifdef _DEBUG_HOMARD_
 380 c 3.5. ==> Ecriture des valeurs brutes
 381 c
 382       if ( codret.eq.0 ) then
 383 c
 384       do 35 , iaux = 1 , nbval
 385         write(ulbrut,92010) rmem(adtra1+iaux-1)
 386    35 continue
 387 c
 388       endif
 389 #endif
 390 c
 391 c 3.6. ==> Fermeture
 392 c
 393       if ( codret.eq.0 ) then
 394 c
 395       call gufeul ( ulhist, codre1 )
 396       if ( .not.consta ) then
 397         call gufeul ( ulxmgr, codre2 )
 398       else
 399         codre2 = 0
 400       endif
 401       codre3 = 0
 402 #ifdef _DEBUG_HOMARD_
 403       call gufeul ( ulbrut, codre3 )
 404 #endif
 405 c
 406       codre0 = min ( codre1, codre2, codre3 )
 407       codret = max ( abs(codre0), codret,
 408      >               codre1, codre2, codre3 )
 409 c
 410       endif
 411 c
 412 c====
 413 c 4. menage
 414 c====
 415 c
 416       if ( codret.eq.0 ) then
 417 c
 418       call gmlboj ( ntrav1 , codre0 )
 419 c
 420       codret = max ( abs(codre0), codret )
 421 c
 422       endif
 423 c
 424 c====
 425 c 5. la fin
 426 c====
 427 c
 428       if ( codret.ne.0 ) then
 429 c
 430 #include "envex2.h"
 431 c
 432       write (ulsort,texte(langue,1)) 'Sortie', nompro
 433       write (ulsort,texte(langue,2)) codret
 434 c
 435       endif
 436 c
 437 #ifdef _DEBUG_HOMARD_
 438       write (ulsort,texte(langue,1)) 'Sortie', nompro
 439       call dmflsh (iaux)
 440 #endif
 441 c
 442       end