src/tool/Information/infc36.F

   1       subroutine infc36 ( numcas, nbcomp, nbentc,
   2      >                    profil, vafoti, vafotr,
   3      >                    quahex, coquhe, arehex,
   4      >                    perhex, nhexca,
   5      >                    coonoe, somare,
   6      >                    arequa, nivqua,
   7      >                    npherc, hexrec,
   8      >                    ulsort, langue, codret )
   9 c ______________________________________________________________________
  10 c
  11 c                             H O M A R D
  12 c
  13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  14 c
  15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  16 c aupres des huissiers de justice Simart et Lavoir a Clamart
  17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  18 c aupres des huissiers de justice
  19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  20 c
  21 c    HOMARD est une marque deposee d'Electricite de France
  22 c
  23 c Copyright EDF 1996
  24 c Copyright EDF 1998
  25 c Copyright EDF 2002
  26 c Copyright EDF 2020
  27 c ______________________________________________________________________
  28 c  INformation - inFormations Complementaires - phase 36
  29 c  --              -          -                       --
  30 c  Valeurs sur les hexaedres
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . numcas . e   .   1    . numero du cas en cours de traitement       .
  36 c .        .     .        . 1 : niveau                                 .
  37 c .        .     .        . 2 : qualite                                .
  38 c .        .     .        . 3 : diametre                               .
  39 c .        .     .        . 4 : parente                                .
  40 c .        .     .        . 5 : voisins des recollements               .
  41 c . nbcomp . e   .   1    . nombre de composantes                      .
  42 c . nbentc . e   .   1    . nombre total d'entites du calcul           .
  43 c . profil .  s  . nbentc . pour chaque entite du calcul :             .
  44 c .        .     .        . 0 : l'entite est absente du profil         .
  45 c .        .     .        . 1 : l'entite est presente dans le profil   .
  46 c . vafoti .  s  . nbentc . tableau temporaire de la fonction          .
  47 c . vafotr .  s  . nbentc . tableau temporaire de la fonction          .
  48 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  49 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  50 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
  51 c . perhex . e   . nbheto . pere des hexaedres                         .
  52 c . nhexca . e   .   *    . nro des hexaedres dans le calcul           .
  53 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  54 c .        .     . * sdim .                                            .
  55 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  56 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  57 c . nivqua . e   . nbquto . niveau dans le raffinement/deraffinement   .
  58 c . npherc . e   .   1    . nombre de paires d'hexaedres recolles      .
  59 c . hexrec . e   .3*npherc. paires des hexa. voisins faces a recoller  .
  60 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  61 c . langue . e   .    1   . langue des messages                        .
  62 c .        .     .        . 1 : francais, 2 : anglais                  .
  63 c . codret . es  .    1   . code de retour des modules                 .
  64 c .        .     .        . 0 : pas de probleme                        .
  65 c .        .     .        . 5 : mauvais type de code de calcul associe .
  66 c ______________________________________________________________________
  67 c
  68 c====
  69 c 0. declarations et dimensionnement
  70 c====
  71 c
  72 c 0.1. ==> generalites
  73 c
  74       implicit none
  75       save
  76 c
  77       character*6 nompro
  78       parameter ( nompro = 'INFC36' )
  79 c
  80 #include "nblang.h"
  81 c
  82 c 0.2. ==> communs
  83 c
  84 #include "envex1.h"
  85 #include "envca1.h"
  86 #include "impr02.h"
  87 #include "nombno.h"
  88 #include "nombar.h"
  89 #include "nombqu.h"
  90 #include "nombhe.h"
  91 c
  92 c 0.3. ==> arguments
  93 c
  94       integer numcas
  95       integer nbcomp, nbentc
  96       integer profil(nbentc)
  97       integer vafoti(nbentc)
  98       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
  99       integer perhex(nbheto), nhexca(*)
 100       integer somare(2,nbarto)
 101       integer arequa(nbquto,4), nivqua(nbquto)
 102       integer npherc, hexrec(3,npherc)
 103 c
 104       double precision coonoe(nbnoto,sdim)
 105       double precision vafotr(nbentc)
 106 c
 107       integer ulsort, langue, codret
 108 c
 109 c 0.4. ==> variables locales
 110 c
 111       integer iaux, jaux, kaux, laux
 112       integer indice, lmax
 113       integer levolu, laface
 114 c
 115       double precision niveau, qualit, qualij, diamet
 116       double precision volume
 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 c
 125 c====
 126 c 1. messages
 127 c====
 128 c
 129 #include "impr01.h"
 130 #include "impr03.h"
 131 c
 132 #ifdef _DEBUG_HOMARD_
 133       write (ulsort,texte(langue,1)) 'Entree', nompro
 134       call dmflsh (iaux)
 135 #endif
 136       texte(1,4) = '(''.. Valeurs sur les '',a)'
 137 c
 138       texte(2,4) = '(''.. Values over the '',a)'
 139 c
 140 #ifdef _DEBUG_HOMARD_
 141       write (ulsort,texte(langue,4)) mess14(langue,3,6)
 142       write (ulsort,90002) 'numcas', numcas
 143       write (ulsort,90002) 'nbheto', nbheto
 144       write (ulsort,90002) 'nbhepe', nbhepe
 145       write (ulsort,90002) 'nbcomp', nbcomp
 146       write (ulsort,90002) 'nbentc', nbentc
 147       write (ulsort,90002) 'npherc', npherc
 148 #endif
 149 c
 150       codret = 0
 151 c
 152 c====
 153 c 2. Rien par defaut
 154 c====
 155 c
 156       do 21 , iaux = 1 , nbentc
 157         profil(iaux) = 0
 158    21 continue
 159 c
 160 c====
 161 c 3. Niveau
 162 c====
 163 c
 164       if ( numcas.eq.1 ) then
 165 c
 166 c 3.1. ==> Les hexaedres de depart ou issus d'un decoupage en 8
 167 c          Les faces sont toutes du meme niveau
 168 c          Remarque : ils sont toujours decrits par faces
 169 c
 170         do 31 , iaux = 1 , nbhepe
 171 c
 172 cgn      write (ulsort,90015) 'nhexca(',iaux,') =', nhexca(iaux)
 173 c
 174           jaux = nhexca(iaux)
 175           if ( jaux.ne.0 ) then
 176 cgn      write (ulsort,90015) 'nivqua(',iaux,') =', nivqua(quahex(iaux,1))
 177             vafotr(jaux) = dble(nivqua(quahex(iaux,1)))
 178             profil(jaux) = 1
 179           endif
 180 c
 181    31   continue
 182 c
 183 c 3.2. ==> Les hexaedres issus d'un decoupage de conformite
 184 c          Remarque : ils sont toujours actifs
 185 c
 186         do 32 , iaux = nbhepe+1 , nbheto
 187 c
 188           call utnhex ( iaux, niveau,
 189      >                  quahex, perhex,
 190      >                  nivqua )
 191 c
 192           jaux = nhexca(iaux)
 193           vafotr(jaux) = niveau
 194           profil(jaux) = 1
 195 c
 196    32   continue
 197 c
 198 c====
 199 c 4. Qualite
 200 c====
 201 c
 202       elseif ( numcas.eq.2 ) then
 203 c
 204         do 41 , iaux = 1 , nbheto
 205 c
 206           jaux = nhexca(iaux)
 207           if ( jaux.ne.0 ) then
 208             kaux = iaux
 209             call utqhex (   kaux, qualit, qualij, volume,
 210      >                    coonoe, somare, arequa,
 211      >                    quahex, coquhe, arehex )
 212             vafotr(jaux) = qualit
 213             profil(jaux) = 1
 214           endif
 215 c
 216    41   continue
 217 c
 218 c====
 219 c 5. Diametre
 220 c====
 221 c
 222       elseif ( numcas.eq.3 ) then
 223 c
 224         do 51 , iaux = 1 , nbheto
 225 c
 226           jaux = nhexca(iaux)
 227           if ( jaux.ne.0 ) then
 228             kaux = iaux
 229             call utdhex ( kaux, diamet,
 230      >                    coonoe, somare, arequa,
 231      >                    quahex, coquhe, arehex )
 232             vafotr(jaux) = diamet
 233             profil(jaux) = 1
 234 c
 235           endif
 236 c
 237    51   continue
 238 c
 239 c====
 240 c 6. Parente
 241 c====
 242 c
 243       elseif ( numcas.eq.4 ) then
 244 c
 245         do 61 , iaux = 1 , nbheto
 246 c
 247           jaux = nhexca(iaux)
 248           if ( jaux.ne.0 ) then
 249             vafoti(jaux) = perhex(iaux)
 250             profil(jaux) = 1
 251           endif
 252 c
 253    61   continue
 254 c
 255 c====
 256 c 7. Voisins par recollement
 257 c====
 258 c
 259       elseif ( numcas.eq.5 ) then
 260 c
 261 c 7.1. ==> On met des valeurs nulles par defaut
 262 c
 263         do 71 , iaux = 1 , nbheto
 264 c
 265           jaux = nhexca(iaux)
 266           if ( jaux.ne.0 ) then
 267             indice = nbcomp*(jaux-1) + 1
 268             do 711 , kaux = 1 , nbcomp
 269               vafoti(indice) = 0
 270               indice = indice + 1
 271   711       continue
 272             profil(jaux) = 1
 273           endif
 274 c
 275    71   continue
 276 c
 277 c 7.2. ==> Parcours des paires enregistrees
 278 c
 279         lmax = nbcomp / 2
 280 c
 281 cgn      write (ulsort,*) 'boucle 720'
 282 cgn      write (ulsort,90002) 'npherc', npherc
 283 cgn      do 720 , iaux = 1 , npherc
 284 cgn          if ( ( hexrec(3,iaux).eq.291 ) .or.
 285 cgn     >         ( hexrec(3,iaux).eq.296 ) ) then
 286 cgn      write (ulsort,90022) 'iaux', iaux, hexrec(1,iaux),
 287 cgn     >                          hexrec(2,iaux), hexrec(3,iaux)
 288 cgn          endif
 289 cgn  720 continue
 290         do 72 , iaux = 1 , npherc
 291 c
 292           jaux = hexrec(1,iaux)
 293           kaux = hexrec(2,iaux)
 294 cgn          write (ulsort,90002) 'iaux, jaux, kaux, face',
 295 cgn     >                          iaux, jaux, kaux, hexrec(3,iaux)
 296 c
 297           if ( jaux.ne.0 ) then
 298 c
 299 cgn            write (ulsort,*) 'boucle 721'
 300             levolu = kaux
 301             laface = hexrec(3,iaux)
 302             indice = nbcomp*(jaux-1) + 1
 303             do 721 , laux = 1, lmax
 304               if ( vafoti(indice).eq.0 ) then
 305                 vafoti(indice) = levolu
 306                 vafoti(indice+1) = laface
 307 cgn      if ( ( hexrec(3,iaux).eq.291 ) .or.
 308 cgn     >     ( hexrec(3,iaux).eq.296 ) ) then
 309 cgn      write (ulsort,90022) 'iaux', iaux, hexrec(1,iaux),
 310 cgn     >                          hexrec(2,iaux), hexrec(3,iaux)
 311 cgn      write (ulsort,90002) ' ==> indice A', indice, laux
 312 cgn      write (ulsort,90002) ' ==> ecriture de', kaux, hexrec(3,iaux)
 313 cgn      endif
 314                 goto 722
 315               elseif ( vafoti(indice+1).eq.laface ) then
 316 cgn      if ( ( hexrec(3,iaux).eq.291 ) .or.
 317 cgn     >     ( hexrec(3,iaux).eq.296 ) ) then
 318 cgn      write (ulsort,90022) 'iaux', iaux, hexrec(1,iaux),
 319 cgn     >                          hexrec(2,iaux), hexrec(3,iaux)
 320 cgn      write (ulsort,90002) ' ==> indice A', indice
 321 cgn      write (ulsort,90002) ' ==> non ecriture de', kaux, hexrec(3,iaux)
 322 cgn      endif
 323                 goto 723
 324 #ifdef _DEBUG_HOMARD_
 325               else
 326       if ( ( hexrec(3,iaux).eq.-291 ) .or.
 327      >     ( hexrec(3,iaux).eq.-296 ) ) then
 328       write (ulsort,90022) 'iaux', iaux, hexrec(1,iaux),
 329      >                          hexrec(2,iaux), hexrec(3,iaux)
 330       write (ulsort,*) '    indice A deja connu',indice,vafoti(indice)
 331       write (ulsort,*) '    recherche d''un autre indice'
 332       endif
 333 #endif
 334               endif
 335               indice = indice + 2
 336   721       continue
 337             codret = 721
 338             write (ulsort,*) 'Ecriture impossible'
 339             write (ulsort,90002) 'iaux', iaux
 340             write (ulsort,90002) '1', hexrec(1,iaux)
 341             write (ulsort,90002) '2', hexrec(2,iaux)
 342             write (ulsort,90002) '3', hexrec(3,iaux)
 343             goto 7999
 344   722       continue
 345   723       continue
 346 c
 347           endif
 348 c
 349           if ( kaux.ne.0 ) then
 350 c
 351 cgn            write (ulsort,*) 'boucle 724'
 352             levolu = jaux
 353             laface = hexrec(3,iaux)
 354             indice = nbcomp*(kaux-1) + 1
 355             do 724 , laux = 1, lmax
 356               if ( vafoti(indice).eq.0 ) then
 357                 vafoti(indice) = levolu
 358                 vafoti(indice+1) = laface
 359 cgn         write (ulsort,90002) ' ==> indice B', indice, laux
 360                 goto 725
 361 cgn            else
 362 cgn          write (ulsort,90112) '    vafoti',indice,vafoti(indice)
 363 cgn          write (ulsort,*) '    indice B deja connu'
 364               endif
 365               indice = indice + 2
 366   724       continue
 367             codret = 724
 368             write (ulsort,*) 'Ecriture impossible'
 369             write (ulsort,90002) 'iaux', iaux
 370             write (ulsort,90002) '1', hexrec(1,iaux)
 371             write (ulsort,90002) '2', hexrec(2,iaux)
 372             write (ulsort,90002) '3', hexrec(3,iaux)
 373             goto 7999
 374   725       continue
 375 c
 376           endif
 377 c
 378    72   continue
 379 c
 380 cgn        do 73 , iaux = 1,nbentc
 381 cgn          write(ulsort,90112)'profil',iaux,profil(iaux)
 382 cgn       write (ulsort,90002) 'indices', nbcomp*(iaux-1)+1,nbcomp*iaux
 383 cgn          write(ulsort,90112)'vafoti',iaux,
 384 cgn     >(vafoti(jaux),jaux=nbcomp*(iaux-1)+1,nbcomp*iaux)
 385 cgn   73 continue
 386 c
 387  7999   continue
 388 c
 389       endif
 390 c
 391 c====
 392 c 8. la fin
 393 c====
 394 c
 395       if ( codret.ne.0 ) then
 396 c
 397 #include "envex2.h"
 398 c
 399       write (ulsort,texte(langue,1)) 'Sortie', nompro
 400       write (ulsort,texte(langue,2)) codret
 401 c
 402       endif
 403 c
 404 #ifdef _DEBUG_HOMARD_
 405       write (ulsort,texte(langue,1)) 'Sortie', nompro
 406       call dmflsh (iaux)
 407 #endif
 408 c
 409       end