src/tool/Creation_Maillage/cmnbco.F

   1       subroutine cmnbco ( nomail,
   2      >                    lgopti, taopti, lgopts, taopts,
   3      >                    lgetco, taetco,
   4      >                    ulsort, langue, codret )
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c    Creation du Maillage - NomBre de mise en COnformite
  26 c    -           -          -  -              --
  27 c ______________________________________________________________________
  28 c
  29 c but : decompte les entites a creer lors du decoupage de mise en
  30 c       conformite des faces et des volumes.
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . nomail . e   .  ch8   . nom de l'objet contenant le maillage       .
  36 c . lgopti . e   .   1    . longueur du tableau des options entieres   .
  37 c . taopti . e   . lgopti . tableau des options                        .
  38 c . lgopts . e   .   1    . longueur du tableau des options caracteres .
  39 c . taopts . e   . lgopts . tableau des options caracteres             .
  40 c . lgetco . e   .   1    . longueur du tableau de l'etat courant      .
  41 c . taetco . e   . lgetco . tableau de l'etat courant                  .
  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 . e/s .   1    . code de retour des modules                 .
  46 c .        .     .        . 0 : pas de probleme                        .
  47 c ______________________________________________________________________
  48 c    Rappel des codes de pilotage du raffinement et deraffinement :
  49 c  30 : mode de conformite
  50 c       0 : conforme (defaut)
  51 c       1 : non-conforme avec 1 seule arete decoupee (en 2)
  52 c           par face (triangle ou quadrangle)
  53 c       2 : non-conforme avec 1 seul noeud pendant par arete
  54 c       3 : non-conforme fidele a l'indicateur
  55 c      -1 : conforme, avec des boites pour les quadrangles, hexaedres
  56 c           et pentaedres
  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 = 'CMNBCO' )
  69 c
  70 #include "nblang.h"
  71 c
  72 c 0.2. ==> communs
  73 c
  74 #include "envex1.h"
  75 #include "gmenti.h"
  76 c
  77 #include "envca1.h"
  78 #include "nombtr.h"
  79 #include "nombqu.h"
  80 #include "nombte.h"
  81 #include "nombhe.h"
  82 #include "nombpe.h"
  83 c
  84 c 0.3. ==> arguments
  85 c
  86       character*8 nomail
  87 c
  88       integer lgopti
  89       integer taopti(lgopti)
  90 c
  91       integer lgopts
  92       character*8 taopts(lgopts)
  93 c
  94       integer lgetco
  95       integer taetco(lgetco)
  96 c
  97       integer ulsort, langue, codret
  98 c
  99 c 0.4. ==> variables locales
 100 c
 101       integer codava
 102       integer nretap, nrsset
 103       integer iaux, jaux, kaux
 104 c
 105       integer codre0
 106       integer codre1, codre2
 107 c
 108       integer pdecar, pdecfa
 109       integer phetar
 110       integer paretr, phettr, pnivtr
 111       integer parequ, phetqu, pnivqu
 112       integer phette, ptrite
 113       integer phethe, pquahe, pcoquh
 114       integer phetpe, pfacpe
 115 c
 116       character*6 saux
 117       character*8 norenu
 118       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 119       character*8 nhtetr, nhhexa, nhpyra, nhpent
 120       character*8 nhelig
 121       character*8 nhvois, nhsupe, nhsups
 122       character*8 ntrav1
 123 c
 124       integer nbmess
 125       parameter ( nbmess = 10 )
 126       character*80 texte(nblang,nbmess)
 127 c
 128 c 0.5. ==> initialisations
 129 c ______________________________________________________________________
 130 c
 131 c====
 132 c 1. messages
 133 c====
 134 c
 135       codava = codret
 136 c
 137 c=======================================================================
 138       if ( codava.eq.0 ) then
 139 c=======================================================================
 140 c
 141 c 1.3. ==> les messages
 142 c
 143 #include "impr01.h"
 144 c
 145 #ifdef _DEBUG_HOMARD_
 146       write (ulsort,texte(langue,1)) 'Entree', nompro
 147       call dmflsh (iaux)
 148 #endif
 149 c
 150       texte(1,4) =
 151      > '(/,a6,'' NOMBRE DE MISES EN CONFORMITE'')'
 152       texte(1,5) = '(36(''=''),/)'
 153       texte(1,6) = '(''Modification de taille des tableaux des '',a)'
 154       texte(1,7) = '(5x,''==> code de retour :'',i8)'
 155 c
 156       texte(2,4) =
 157      > '(/,a6,'' NUMBER OF REQUESTED CONFORMITY OPERATIONS'')'
 158       texte(2,5) = '(48(''=''),/)'
 159       texte(2,6) = '(''Size modification of arrays for '',a)'
 160       texte(2,7) = '(5x,''==> error code :'',i8)'
 161 c
 162 #include "impr03.h"
 163 c
 164 c 1.4. ==> le numero de sous-etape
 165 c
 166       nretap = taetco(1)
 167       nrsset = taetco(2) + 1
 168       taetco(2) = nrsset
 169 c
 170       call utcvne ( nretap, nrsset, saux, iaux, codret )
 171 c
 172 c 1.5. ==> le titre
 173 c
 174       write ( ulsort,texte(langue,4)) saux
 175       write ( ulsort,texte(langue,5))
 176 c
 177 c====
 178 c 2. recuperation des pointeurs
 179 c====
 180 c
 181       if ( codret.eq.0 ) then
 182 c
 183 #ifdef _DEBUG_HOMARD_
 184       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 185 #endif
 186 c
 187       call utnomh ( nomail,
 188      >                sdim,   mdim,
 189      >               degre, maconf, homolo, hierar,
 190      >              rafdef, nbmane, typcca, typsfr, maextr,
 191      >              mailet,
 192      >              norenu,
 193      >              nhnoeu, nhmapo, nharet,
 194      >              nhtria, nhquad,
 195      >              nhtetr, nhhexa, nhpyra, nhpent,
 196      >              nhelig,
 197      >              nhvois, nhsupe, nhsups,
 198      >              ulsort, langue, codret)
 199 c
 200       endif
 201 c
 202       if ( codret.eq.0 ) then
 203 c
 204       ntrav1 = taopts(11)
 205       call gmadoj ( ntrav1, pdecar, iaux, codre1 )
 206       ntrav1 = taopts(12)
 207       call gmadoj ( ntrav1, pdecfa, iaux, codre2 )
 208 c
 209       codre0 = min ( codre1, codre2 )
 210       codret = max ( abs(codre0), codret,
 211      >               codre1, codre2 )
 212 c
 213       endif
 214 c
 215       if ( codret.eq.0 ) then
 216 c
 217 #ifdef _DEBUG_HOMARD_
 218       write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
 219 #endif
 220       iaux = 2
 221       call utad02 ( iaux, nharet,
 222      >              phetar, kaux  , jaux  , jaux  ,
 223      >                jaux,   jaux,   jaux,
 224      >                jaux,   jaux,   jaux,
 225      >                jaux,   jaux,   jaux,
 226      >              ulsort, langue, codret )
 227 c
 228       if ( nbtrto.ne.0 ) then
 229 c
 230 #ifdef _DEBUG_HOMARD_
 231       write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
 232 #endif
 233         iaux = 2
 234         call utad02 ( iaux, nhtria,
 235      >                phettr, paretr, jaux  , jaux  ,
 236      >                  jaux,   jaux,   jaux,
 237      >                pnivtr,   jaux,   jaux,
 238      >                  jaux,   jaux,   jaux,
 239      >                ulsort, langue, codret )
 240 c
 241       endif
 242 c
 243       if ( nbquto.ne.0 ) then
 244 c
 245 #ifdef _DEBUG_HOMARD_
 246       write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
 247 #endif
 248         iaux = 2
 249         call utad02 ( iaux, nhquad,
 250      >                phetqu, parequ, jaux  , jaux  ,
 251      >                  jaux,   jaux,   jaux,
 252      >                pnivqu,   jaux,   jaux,
 253      >                  jaux,   jaux,   jaux,
 254      >                ulsort, langue, codret )
 255 c
 256       endif
 257 c
 258       if ( nbteto.ne.0 ) then
 259 c
 260 #ifdef _DEBUG_HOMARD_
 261       write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
 262 #endif
 263         iaux = 2
 264         call utad02 ( iaux, nhtetr,
 265      >                phette, ptrite, jaux  , jaux,
 266      >                  jaux,   jaux,   jaux,
 267      >                  jaux,   jaux,   jaux,
 268      >                  jaux,   jaux,   jaux,
 269      >                ulsort, langue, codret )
 270 c
 271       endif
 272 c
 273       endif
 274 c
 275       if ( nbheto.ne.0 ) then
 276 c
 277 #ifdef _DEBUG_HOMARD_
 278       write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
 279 #endif
 280         iaux = 2
 281         if ( taopti(30).ge.0 ) then
 282           iaux = iaux*13
 283         endif
 284         call utad02 ( iaux, nhhexa,
 285      >                phethe, pquahe, jaux  , jaux,
 286      >                  jaux,   jaux,   jaux,
 287      >                  jaux, pcoquh,   jaux,
 288      >                  jaux,   jaux,   jaux,
 289      >                ulsort, langue, codret )
 290 c
 291       endif
 292 c
 293       if ( nbpeto.ne.0 ) then
 294 c
 295 #ifdef _DEBUG_HOMARD_
 296       write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
 297 #endif
 298         iaux = 2
 299         call utad02 ( iaux, nhpent,
 300      >                phetpe, pfacpe, jaux  , jaux,
 301      >                  jaux,   jaux,   jaux,
 302      >                  jaux,   jaux,   jaux,
 303      >                  jaux,   jaux,   jaux,
 304      >                ulsort, langue, codret )
 305 c
 306       endif
 307 c
 308 c====
 309 c 3. decompte des nouvelles entites a creer
 310 c====
 311 #ifdef _DEBUG_HOMARD_
 312       write (ulsort,90002) '3. decompte ; codret', codret
 313 #endif
 314 c
 315       if ( codret.eq.0 ) then
 316 c
 317 #ifdef _DEBUG_HOMARD_
 318       write (ulsort,texte(langue,3)) 'UTPLCO', nompro
 319 #endif
 320 c
 321       call utplco ( taopti(30),
 322      >              imem(pdecar), imem(pdecfa),
 323      >              imem(phetar),
 324      >              imem(phettr), imem(paretr),
 325      >              imem(phetqu), imem(parequ),
 326      >              imem(phette), imem(ptrite),
 327      >              imem(phethe), imem(pquahe), imem(pcoquh),
 328      >              imem(phetpe), imem(pfacpe),
 329      >              ulsort, langue, codret )
 330 c
 331       endif
 332 c
 333 c====
 334 c 4. la fin
 335 c====
 336 c
 337       if ( codret.ne.0 ) then
 338 c
 339 #include "envex2.h"
 340 c
 341       write (ulsort,texte(langue,1)) 'Sortie', nompro
 342       write (ulsort,texte(langue,2)) codret
 343 c
 344       endif
 345 c
 346 #ifdef _DEBUG_HOMARD_
 347       write (ulsort,texte(langue,1)) 'Sortie', nompro
 348       call dmflsh (iaux)
 349 #endif
 350 c
 351 c=======================================================================
 352       endif
 353 c=======================================================================
 354 c
 355       end