src/tool/Creation_Maillage/cmalra.F

   1       subroutine cmalra ( nomail,
   2      >                    indnoe, indnp2, indnim, indare,
   3      >                    indtri, indqua,
   4      >                    indtet, indhex, indpen,
   5      >                    lgopts, taopts, lgetco, taetco,
   6      >                    ulsort, langue, codret )
   7 c ______________________________________________________________________
   8 c
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c
  27 c    Creation du Maillage - ALlocation pour le RAffinement
  28 c    -           -          --                 --
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . nomail . e   .  ch8   . nom de l'objet contenant le maillage       .
  34 c . indnoe . es  .   1    . indice du dernier noeud cree               .
  35 c . indnp2 . es  .   1    . nombre de noeuds p2 en vigueur             .
  36 c . indnim . es  .   1    . nombre de noeuds internes en vigueur       .
  37 c . indare . es  .   1    . indice de la derniere arete creee          .
  38 c . indtri . es  .   1    . indice du dernier triangle cree            .
  39 c . indqua . es  .   1    . indice du dernier quadrangle cree          .
  40 c . indtet . es  .   1    . indice du dernier tetraedre cree           .
  41 c . indhex . es  .   1    . indice du dernier hexaedre cree            .
  42 c . indpen . es  .   1    . indice du dernier pentaedre cree           .
  43 c . lgopts . e   .   1    . longueur du tableau des options caracteres .
  44 c . taopts . e   . lgopts . tableau des options caracteres             .
  45 c . lgetco . e   .   1    . longueur du tableau de l'etat courant      .
  46 c . taetco . e   . lgetco . tableau de l'etat courant                  .
  47 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  48 c . langue . e   .   1    . langue des messages                        .
  49 c .        .     .        . 1 : francais, 2 : anglais                  .
  50 c . codret . e/s .   1    . code de retour des modules                 .
  51 c .        .     .        . 0 : pas de probleme                        .
  52 c ______________________________________________________________________
  53 c
  54 c====
  55 c 0. declarations et dimensionnement
  56 c====
  57 c
  58 c 0.1. ==> generalites
  59 c
  60       implicit none
  61       save
  62 c
  63       character*6 nompro
  64       parameter ( nompro = 'CMALRA' )
  65 c
  66 #include "nblang.h"
  67 c
  68 c 0.2. ==> communs
  69 c
  70 #include "envex1.h"
  71 #include "envca1.h"
  72 c
  73 c 0.3. ==> arguments
  74 c
  75       character*8 nomail
  76 c
  77       integer indnoe, indnp2, indnim, indare, indtri, indqua
  78       integer indtet, indhex, indpen
  79 c
  80       integer lgopts
  81       character*8 taopts(lgopts)
  82 c
  83       integer lgetco
  84       integer taetco(lgetco)
  85 c
  86       integer ulsort, langue, codret
  87 c
  88 c 0.4. ==> variables locales
  89 c
  90       integer codava
  91       integer nretap, nrsset
  92       integer iaux, jaux
  93 c
  94       integer nbsoan, nbsono
  95       integer nbnoan, nbnono
  96       integer nbaran, nbarno
  97       integer nbtran, nbtrno
  98       integer nbquan, nbquno
  99       integer nbtean, nbteno
 100       integer nbhean, nbheno
 101       integer nbpean, nbpeno
 102       integer nbpyan, nbpyno
 103 c
 104       character*6 saux
 105       character*8 norenu
 106       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 107       character*8 nhtetr, nhhexa, nhpyra, nhpent
 108       character*8 nhelig
 109       character*8 nhvois, nhsupe, nhsups
 110       character*8 ndecar, ndecfa
 111 c
 112       logical extrus
 113 c
 114       integer nbmess
 115       parameter ( nbmess = 10 )
 116       character*80 texte(nblang,nbmess)
 117 c
 118 c 0.5. ==> initialisations
 119 c ______________________________________________________________________
 120 c
 121 c====
 122 c 1. messages
 123 c====
 124 c
 125       codava = codret
 126 c
 127 c=======================================================================
 128       if ( codava.eq.0 ) then
 129 c=======================================================================
 130 c
 131 c 1.3. ==> les messages
 132 c
 133 #include "impr01.h"
 134 c
 135 #ifdef _DEBUG_HOMARD_
 136       write (ulsort,texte(langue,1)) 'Entree', nompro
 137       call dmflsh (iaux)
 138 #endif
 139 c
 140       texte(1,4) =
 141      > '(/,a6,'' ALLOCATION MEMOIRE POUR LE DECOUPAGE STANDARD'')'
 142       texte(1,5) = '(52(''=''),/)'
 143 c
 144       texte(2,4) =
 145      > '(/,a6,'' MEMORY ALLOCATION FOR STANDARD REFINEMENT'')'
 146       texte(2,5) = '(48(''=''),/)'
 147 c
 148 #include "impr03.h"
 149 c
 150 c 1.4. ==> le numero de sous-etape
 151 c
 152       nretap = taetco(1)
 153       nrsset = taetco(2) + 1
 154       taetco(2) = nrsset
 155 c
 156       call utcvne ( nretap, nrsset, saux, iaux, codret )
 157 c
 158 c 1.5. ==> le titre
 159 c
 160       write (ulsort,texte(langue,4)) saux
 161       write (ulsort,texte(langue,5))
 162 c
 163 c====
 164 c 2. recuperation des pointeurs
 165 c====
 166 c
 167       if ( codret.eq.0 ) then
 168 c
 169 #ifdef _DEBUG_HOMARD_
 170       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 171 #endif
 172 c
 173       call utnomh ( nomail,
 174      >                sdim,   mdim,
 175      >               degre, maconf, homolo, hierar,
 176      >              rafdef, nbmane, typcca, typsfr, maextr,
 177      >              mailet,
 178      >              norenu,
 179      >              nhnoeu, nhmapo, nharet,
 180      >              nhtria, nhquad,
 181      >              nhtetr, nhhexa, nhpyra, nhpent,
 182      >              nhelig,
 183      >              nhvois, nhsupe, nhsups,
 184      >              ulsort, langue, codret)
 185 c
 186       endif
 187 c
 188 c====
 189 c 3. programmes generiques
 190 c====
 191 #ifdef _DEBUG_HOMARD_
 192       write (ulsort,90002) '3. programmes generiques ; codret', codret
 193 #endif
 194 c
 195 c 3.1. ==> Base
 196 c
 197       ndecar = taopts(11)
 198       ndecfa = taopts(12)
 199 cgn      call gmprsx(nompro, ndecar)
 200 cgn      call gmprsx(nompro, ndecfa)
 201 c
 202 c 3.2. ==> Nombre de valeurs
 203 c
 204       if ( codret.eq.0 ) then
 205 c
 206       iaux = 0
 207       jaux = 1
 208 c
 209 #ifdef _DEBUG_HOMARD_
 210       write (ulsort,texte(langue,3)) 'UTAL00', nompro
 211 #endif
 212       call utal00 (   iaux,   jaux,
 213      >              nomail, ndecar, ndecfa,
 214      >              indnoe, indnp2, indnim, indare,
 215      >              indtri, indqua,
 216      >              indtet, indhex, indpen,
 217      >              nbsoan, nbsono,
 218      >              nbnoan, nbnono,
 219      >              nbaran, nbarno,
 220      >              nbtran, nbtrno,
 221      >              nbquan, nbquno,
 222      >              nbtean, nbteno,
 223      >              nbhean, nbheno,
 224      >              nbpean, nbpeno,
 225      >              nbpyan, nbpyno,
 226      >              ulsort, langue, codret )
 227 c
 228       endif
 229 c
 230 c 3.3. ==> Reallocation des tableaux avec les nouvelles dimensions
 231 c
 232       if ( codret.eq.0 ) then
 233 c
 234       iaux = 0
 235       if ( typcca.eq.26 .or .typcca.eq.46 ) then
 236         extrus = .false.
 237       elseif ( maextr.ne.0 ) then
 238         extrus = .true.
 239       else
 240         extrus = .false.
 241       endif
 242       jaux = 0
 243 c
 244 #ifdef _DEBUG_HOMARD_
 245       write (ulsort,texte(langue,3)) 'CMAL01', nompro
 246 #endif
 247       call cmal01 (   iaux, extrus,
 248      >              nomail, ndecfa,
 249      >              nbnoan, nbnono,
 250      >              nbaran, nbarno,
 251      >              nbtran, nbtrno,
 252      >              nbquan, nbquno,
 253      >              nbtean, nbteno, jaux, jaux,
 254      >              nbhean, nbheno, jaux, jaux,
 255      >              nbpean, nbpeno, jaux, jaux,
 256      >              nbpyan, nbpyno, jaux, jaux,
 257      >              ulsort, langue, codret )
 258 c
 259       endif
 260 c
 261 c====
 262 c 4. la fin
 263 c====
 264 c
 265       if ( codret.ne.0 ) then
 266 c
 267 #include "envex2.h"
 268 c
 269       write (ulsort,texte(langue,1)) 'Sortie', nompro
 270       write (ulsort,texte(langue,2)) codret
 271 c
 272       endif
 273 c
 274 #ifdef _DEBUG_HOMARD_
 275       write (ulsort,texte(langue,1)) 'Sortie', nompro
 276       call dmflsh (iaux)
 277 #endif
 278 c
 279 c=======================================================================
 280       endif
 281 c=======================================================================
 282 c
 283       end