src/tool/Decision/deini0.F

   1       subroutine deini0 ( nohind, typind, ncmpin,
   2      >                    nbvnoe, nbvare,
   3      >                    nbvtri, nbvqua,
   4      >                    nbvtet, nbvhex, nbvpyr, nbvpen,
   5      >                    adnoin, adnorn, adnosu,
   6      >                    adarin, adarrn, adarsu,
   7      >                    adtrin, adtrrn, adtrsu,
   8      >                    adquin, adqurn, adqusu,
   9      >                    adtein, adtern, adtesu,
  10      >                    adhein, adhern, adhesu,
  11      >                    adpyin, adpyrn, adpysu,
  12      >                    adpein, adpern, adpesu,
  13      >                    ulsort, langue, codret )
  14 c ______________________________________________________________________
  15 c
  16 c                             H O M A R D
  17 c
  18 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  19 c
  20 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  21 c aupres des huissiers de justice Simart et Lavoir a Clamart
  22 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  23 c aupres des huissiers de justice
  24 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  25 c
  26 c    HOMARD est une marque deposee d'Electricite de France
  27 c
  28 c Copyright EDF 1996
  29 c Copyright EDF 1998
  30 c Copyright EDF 2002
  31 c Copyright EDF 2020
  32 c ______________________________________________________________________
  33 c
  34 c traitement des DEcisions - INITialisations - phase 0
  35 c                --          ---                     -
  36 c ______________________________________________________________________
  37 c  Recuperation des adresses pour les indicateurs
  38 c ______________________________________________________________________
  39 c .        .     .        .                                            .
  40 c .  nom   . e/s . taille .           description                      .
  41 c .____________________________________________________________________.
  42 c . nohind . e   .  ch8   . nom de l'objet contenant l'indicateur      .
  43 c . typind .  s  .   1    . type de valeurs                            .
  44 c .        .     .        . 2 : entieres                               .
  45 c .        .     .        . 3 : reelles                                .
  46 c . ncmpin .  s  .   1    . nombre de composantes de l'indicateur      .
  47 c . nbvent .  s  .   1    . nombre de valeurs pour l'entite            .
  48 c . adensu .  s  .   1    . adresse du support                         .
  49 c . adenin .  s  .   1    . adresse des valeurs entieres               .
  50 c . adenrn .  s  .   1    . adresse des valeurs reelles                .
  51 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  52 c . langue . e   .    1   . langue des messages                        .
  53 c .        .     .        . 1 : francais, 2 : anglais                  .
  54 c . codret . es  .    1   . code de retour des modules                 .
  55 c .        .     .        . 0 : pas de probleme                        .
  56 c ______________________________________________________________________
  57 c
  58 c====
  59 c 0. declarations et dimensionnement
  60 c====
  61 c
  62 c 0.1. ==> generalites
  63 c
  64       implicit none
  65       save
  66 c
  67       character*6 nompro
  68       parameter ( nompro = 'DEINI0' )
  69 c
  70 #include "nblang.h"
  71 c
  72 c 0.2. ==> communs
  73 c
  74 #include "envex1.h"
  75 c
  76 #include "impr02.h"
  77 #include "nombtr.h"
  78 #include "nombqu.h"
  79 #include "nombte.h"
  80 #include "nombpy.h"
  81 #include "nombhe.h"
  82 #include "nombpe.h"
  83 #ifdef _DEBUG_HOMARD_
  84 #include "nombar.h"
  85 #include "nombno.h"
  86 #include "enti01.h"
  87 #endif
  88 c
  89 c 0.3. ==> arguments
  90 c
  91       character*8 nohind
  92 c
  93       integer typind, ncmpin
  94       integer nbvnoe, nbvare
  95       integer nbvtri, nbvqua
  96       integer nbvtet, nbvhex, nbvpyr, nbvpen
  97       integer adnoin, adnorn, adnosu
  98       integer adarin, adarrn, adarsu
  99       integer adtrin, adtrrn, adtrsu
 100       integer adquin, adqurn, adqusu
 101       integer adtein, adtern, adtesu
 102       integer adhein, adhern, adhesu
 103       integer adpyin, adpyrn, adpysu
 104       integer adpein, adpern, adpesu
 105 c
 106       integer ulsort, langue, codret
 107 c
 108 c 0.4. ==> variables locales
 109 c
 110       integer iaux, jaux
 111       integer typin0(-1:7)
 112       integer ncmpi0(-1:7)
 113 c
 114       integer codre0
 115 c
 116 #ifdef _DEBUG_HOMARD_
 117       integer kaux
 118       character*15 saux15
 119 #endif
 120 c
 121       integer nbmess
 122       parameter ( nbmess = 10 )
 123       character*80 texte(nblang,nbmess)
 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 c 1.1. ==>les messages
 140 c
 141       texte(1,4) = '(''La structure nohind est inconnue.'')'
 142       texte(1,5) = '(a,'' pour les '',a,'' :'',i4)'
 143       texte(1,6) = '(''Les types d''''indicateurs sont incoherents.'')'
 144       texte(1,7) = '(''Les nombres de composantes sont incoherents.'')'
 145 c
 146       texte(2,4) = '(''nohind structure is unknown.'')'
 147       texte(2,5) = '(a,'' for the '',a,'':'',i4)'
 148       texte(2,6) = '(''Non coherent types for indicators.'')'
 149       texte(2,7) = '(''Non coherent numbers for components.'')'
 150 c
 151 #include "impr03.h"
 152 c
 153 c 1.2. ==> les types d'indicateurs : aucun pour le moment
 154 c
 155       do 12 , iaux = -1 , 7
 156         typin0(iaux) = 0
 157         ncmpi0(iaux) = 0
 158    12 continue
 159 c
 160       codret = 0
 161 c
 162 c====
 163 c 2. La structure generale de l'indicateur d'erreur
 164 c====
 165 c
 166       call gmobal ( nohind, codre0 )
 167       if ( codre0.ne.1 ) then
 168         codret = 1
 169       endif
 170 c
 171 #ifdef _DEBUG_HOMARD_
 172       if ( codret.eq.0 ) then
 173       call gmprsx (nompro, nohind )
 174       do 23000 , iaux = 1 , 1
 175 cgn      do 23000 , iaux = 1 , 2
 176         if ( iaux.eq.1 ) then
 177           saux15(8:15) = 'ValeursR'
 178         else
 179           saux15(8:15) = 'ValeursE'
 180         endif
 181         do 2999 , jaux = -1, 7
 182           kaux = 0
 183           if ( jaux.eq.-1 ) then
 184             kaux = nbnoto
 185           elseif ( jaux.eq.1 ) then
 186             kaux = nbarto
 187           elseif ( jaux.eq.2 ) then
 188             kaux = nbtrto
 189           elseif ( jaux.eq.3 ) then
 190             kaux = nbteto
 191           elseif ( jaux.eq.4 ) then
 192             kaux = nbquto
 193           elseif ( jaux.eq.5 ) then
 194             kaux = nbpyto
 195           elseif ( jaux.eq.6 ) then
 196             kaux = nbheto
 197           elseif ( jaux.eq.7 ) then
 198             kaux = nbpeto
 199           endif
 200           if ( kaux.gt.0 ) then
 201             saux15(1:7) = '.'//suffix(1,jaux)(1:5)//'.'
 202             call gmobal ( nohind//saux15, codre0 )
 203             if ( codre0.eq.2 ) then
 204 cgn              call gmprsx ( nompro, nohind//saux15 )
 205               call gmprot (nompro, nohind//saux15, 1, min(kaux,50) )
 206               if ( kaux.gt.50 ) then
 207                 call gmprot (nompro, nohind//saux15,
 208      >                       max(1,kaux-49),kaux)
 209               endif
 210             endif
 211           endif
 212  2999   continue
 213 23000 continue
 214       endif
 215 #endif
 216 c
 217 c====
 218 c 3. Les adresses par type d'entites
 219 c    Le type (entier/reel) doit etre le meme pour toutes
 220 c====
 221 c
 222 c 3.1. ==> noeuds
 223 c
 224       if ( codret.eq.0 ) then
 225 c
 226 #ifdef _DEBUG_HOMARD_
 227       write (ulsort,texte(langue,3)) 'UTAD31_no', nompro
 228 #endif
 229       iaux = -30
 230       jaux = -1
 231       call utad31 ( iaux, nohind, jaux,
 232      >              nbvnoe, ncmpin,
 233      >              adnosu, adnoin, adnorn, typind,
 234      >              ulsort, langue, codret )
 235       typin0(jaux) = typind
 236       ncmpi0(jaux) = ncmpin
 237 c
 238       endif
 239 c
 240 c 3.2. ==> aretes
 241 c
 242       if ( codret.eq.0 ) then
 243 c
 244 #ifdef _DEBUG_HOMARD_
 245       write (ulsort,texte(langue,3)) 'UTAD31_ar', nompro
 246 #endif
 247       iaux = -30
 248       jaux = 1
 249       call utad31 ( iaux, nohind, jaux,
 250      >              nbvare, ncmpin,
 251      >              adarsu, adarin, adarrn, typind,
 252      >              ulsort, langue, codret )
 253       typin0(jaux) = typind
 254       ncmpi0(jaux) = ncmpin
 255 c
 256       endif
 257 c
 258 c 3.3. ==> triangles
 259 c
 260       if ( nbtrto.gt.0 ) then
 261 c
 262         if ( codret.eq.0 ) then
 263 c
 264 #ifdef _DEBUG_HOMARD_
 265         write (ulsort,texte(langue,3)) 'UTAD31_tr', nompro
 266 #endif
 267         iaux = -30
 268         jaux = 2
 269         call utad31 ( iaux, nohind, jaux,
 270      >                nbvtri, ncmpin,
 271      >                adtrsu, adtrin, adtrrn, typind,
 272      >                ulsort, langue, codret )
 273         typin0(jaux) = typind
 274         ncmpi0(jaux) = ncmpin
 275 c
 276         endif
 277 c
 278       else
 279 c
 280         nbvtri = 0
 281 c
 282       endif
 283 c
 284 c 3.4. ==> quadrangles
 285 c
 286       if ( nbquto.gt.0 ) then
 287 c
 288         if ( codret.eq.0 ) then
 289 c
 290 #ifdef _DEBUG_HOMARD_
 291         write (ulsort,texte(langue,3)) 'UTAD31_qu', nompro
 292 #endif
 293         iaux = -30
 294         jaux = 4
 295         call utad31 ( iaux, nohind, jaux,
 296      >                nbvqua, ncmpin,
 297      >                adqusu, adquin, adqurn, typind,
 298      >                ulsort, langue, codret )
 299         typin0(jaux) = typind
 300         ncmpi0(jaux) = ncmpin
 301 c
 302         endif
 303 c
 304       else
 305 c
 306         nbvqua = 0
 307 c
 308       endif
 309 c
 310 c 3.5. ==> tetraedres
 311 c
 312       if ( nbteto.gt.0 ) then
 313 c
 314         if ( codret.eq.0 ) then
 315 c
 316 #ifdef _DEBUG_HOMARD_
 317         write (ulsort,texte(langue,3)) 'UTAD31_te', nompro
 318 #endif
 319         iaux = -30
 320         jaux = 3
 321         call utad31 ( iaux, nohind, jaux,
 322      >                nbvtet, ncmpin,
 323      >                adtesu, adtein, adtern, typind,
 324      >                ulsort, langue, codret )
 325         typin0(jaux) = typind
 326         ncmpi0(jaux) = ncmpin
 327 c
 328         endif
 329 c
 330       else
 331 c
 332         nbvtet = 0
 333 c
 334       endif
 335 c
 336 c 3.6. ==> pyramides
 337 c
 338       if ( nbpyto.gt.0 ) then
 339 c
 340         if ( codret.eq.0 ) then
 341 c
 342 #ifdef _DEBUG_HOMARD_
 343         write (ulsort,texte(langue,3)) 'UTAD31_py', nompro
 344 #endif
 345         iaux = -30
 346         jaux = 5
 347         call utad31 ( iaux, nohind, jaux,
 348      >                nbvpyr, ncmpin,
 349      >                adpysu, adpyin, adpyrn, typind,
 350      >                ulsort, langue, codret )
 351         typin0(jaux) = typind
 352         ncmpi0(jaux) = ncmpin
 353 c
 354         endif
 355 c
 356       else
 357 c
 358         nbvpyr = 0
 359 c
 360       endif
 361 c
 362 c 3.7. ==> hexaedres
 363 c
 364       if ( nbheto.gt.0 ) then
 365 c
 366         if ( codret.eq.0 ) then
 367 c
 368 #ifdef _DEBUG_HOMARD_
 369         write (ulsort,texte(langue,3)) 'UTAD31_he', nompro
 370 #endif
 371         iaux = -30
 372         jaux = 6
 373         call utad31 ( iaux, nohind, jaux,
 374      >                nbvhex, ncmpin,
 375      >                adhesu, adhein, adhern, typind,
 376      >                ulsort, langue, codret )
 377         typin0(jaux) = typind
 378         ncmpi0(jaux) = ncmpin
 379 c
 380         endif
 381 c
 382       else
 383 c
 384         nbvhex = 0
 385 c
 386       endif
 387 c
 388 c 3.8. ==> pentaedres
 389 c
 390       if ( nbpeto.gt.0 ) then
 391 c
 392         if ( codret.eq.0 ) then
 393 c
 394 #ifdef _DEBUG_HOMARD_
 395         write (ulsort,texte(langue,3)) 'UTAD31_pe', nompro
 396 #endif
 397         iaux = -30
 398         jaux = 7
 399         call utad31 ( iaux, nohind, jaux,
 400      >                nbvpen, ncmpin,
 401      >                adpesu, adpein, adpern, typind,
 402      >                ulsort, langue, codret )
 403         typin0(jaux) = typind
 404         ncmpi0(jaux) = ncmpin
 405 c
 406         endif
 407 c
 408       else
 409 c
 410         nbvpen = 0
 411 c
 412       endif
 413 c
 414 c====
 415 c 4. Le type (entier/reel) doit etre le meme pour toutes les entites
 416 c    Idem pour le nombre de composantes
 417 c====
 418 c
 419       if ( codret.eq.0 ) then
 420 c
 421       typind = 0
 422       ncmpin = 0
 423       do 41 , iaux = -1 , 7
 424 c
 425 #ifdef _DEBUG_HOMARD_
 426         write (ulsort,texte(langue,5)) 'typind',
 427      >         mess14(langue,3,iaux), typin0(iaux)
 428         write (ulsort,texte(langue,5)) 'ncmpin',
 429      >         mess14(langue,3,iaux), ncmpi0(iaux)
 430 #endif
 431         if ( typin0(iaux).ne.0 ) then
 432           if ( typind.eq.0 ) then
 433             typind = typin0(iaux)
 434           else
 435             if ( typind.ne.typin0(iaux) ) then
 436               codret = 2
 437             endif
 438           endif
 439         endif
 440         if ( ncmpi0(iaux).ne.0 ) then
 441           if ( ncmpin.eq.0 ) then
 442             ncmpin = ncmpi0(iaux)
 443           else
 444             if ( ncmpin.ne.ncmpi0(iaux) ) then
 445               codret = 3
 446             endif
 447           endif
 448         endif
 449 c
 450    41 continue
 451 c
 452       endif
 453 c
 454 #ifdef _DEBUG_HOMARD_
 455       write (ulsort,90002)
 456      >'nbvnoe, nbvare, nbvtri, nbvqua, nbvtet, nbvhex, nbvpyr, nbvpen',
 457      >                     nbvnoe, nbvare,
 458      >                     nbvtri, nbvqua,
 459      >                     nbvtet, nbvhex, nbvpyr, nbvpen
 460 #endif
 461 c
 462 c====
 463 c 5. la fin
 464 c====
 465 c
 466       if ( codret.ne.0 ) then
 467 c
 468 #include "envex2.h"
 469 c
 470       write (ulsort,texte(langue,1)) 'Sortie', nompro
 471       write (ulsort,texte(langue,2)) codret
 472       if ( codret.eq.1 ) then
 473         write (ulsort,texte(langue,4))
 474       elseif ( codret.eq.2 ) then
 475         do 51 , iaux = -1 , 7
 476 #ifdef _DEBUG_HOMARD_
 477           if ( typin0(iaux).ge.0 ) then
 478 #else
 479           if ( typin0(iaux).ne.0 ) then
 480 #endif
 481             write (ulsort,texte(langue,5)) 'typind',
 482      >             mess14(langue,3,iaux), typin0(iaux)
 483           endif
 484    51   continue
 485         write (ulsort,texte(langue,6))
 486       elseif ( codret.eq.3 ) then
 487         do 52 , iaux = -1 , 7
 488 #ifdef _DEBUG_HOMARD_
 489           if ( ncmpi0(iaux).ge.0 ) then
 490 #else
 491           if ( ncmpi0(iaux).ne.0 ) then
 492 #endif
 493             write (ulsort,texte(langue,5)) 'ncmpin',
 494      >             mess14(langue,3,iaux), ncmpi0(iaux)
 495           endif
 496    52   continue
 497         write (ulsort,texte(langue,7))
 498       endif
 499 c
 500       endif
 501 c
 502 #ifdef _DEBUG_HOMARD_
 503       write (ulsort,texte(langue,1)) 'Sortie', nompro
 504       call dmflsh (iaux)
 505 #endif
 506 c
 507       end