src/tool/AV_Conversion/vcinrr.F

   1       subroutine vcinrr ( nbvent,
   2      >                    nosupp, noindi,
   3      >                    arsupp, arindi,
   4      >                    trsupp, trindi,
   5      >                    qusupp, quindi,
   6      >                    tesupp, teindi,
   7      >                    hesupp, heindi,
   8      >                    pysupp, pyindi,
   9      >                    pesupp, peindi,
  10      >                    nbvapr, listpr,
  11      >                    nbtafo, nbvind, indica,
  12      >                    ncmpin, nucomp,
  13      >                    nnovho,
  14      >                    narvho,
  15      >                    ntrvho,
  16      >                    nquvho,
  17      >                    ntevho,
  18      >                    nhevho,
  19      >                    npyvho,
  20      >                    npevho,
  21      >                    ulsort, langue, codret)
  22 c ______________________________________________________________________
  23 c
  24 c                             H O M A R D
  25 c
  26 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  27 c
  28 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  29 c aupres des huissiers de justice Simart et Lavoir a Clamart
  30 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  31 c aupres des huissiers de justice
  32 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  33 c
  34 c    HOMARD est une marque deposee d'Electricite de France
  35 c
  36 c Copyright EDF 1996
  37 c Copyright EDF 1998
  38 c Copyright EDF 2002
  39 c Copyright EDF 2020
  40 c ______________________________________________________________________
  41 c
  42 c    aVant adaptation - Conversion d'INdicateur - REel
  43 c     -                 -            --           --
  44 c but : conversion de l'indicateur d'erreur
  45 c       valeurs reelles double precision de l'indicateur
  46 c               ========================
  47 c ______________________________________________________________________
  48 c .        .     .        .                                            .
  49 c .  nom   . e/s . taille .           description                      .
  50 c .____________________________________________________________________.
  51 c . nbvent .  e .   -1:7  . nombre d'entites actives pour chaque type  .
  52 c .        .     .        . d'element au sens HOMARD avec indicateur   .
  53 c . nosupp .  s  . nbnoto . support pour les noeuds                    .
  54 c . noindi .  s  . nbnoto . valeurs pour les noeuds                    .
  55 c . arsupp .  s  . nbarto . support pour les aretes                    .
  56 c . arindi .  s  . nbarto . valeurs pour les aretes                    .
  57 c . trsupp .  s  . nbtrto . support pour les triangles                 .
  58 c . trindi .  s  . nbtrto . valeurs pour les triangles                 .
  59 c . qusupp .  s  . nbquto . support pour les quadrangles               .
  60 c . quindi .  s  . nbquto . valeurs pour les quadrangles               .
  61 c . tesupp .  s  . nbteto . support pour les tetraedres                .
  62 c . teindi .  s  . nbteto . valeurs pour les tetraedres                .
  63 c . hesupp .  s  . nbheto . support pour les hexaedres                 .
  64 c . heindi .  s  . nbheto . valeurs pour les hexaedres                 .
  65 c . pysupp .  s  . nbpyto . support pour les pyramides                 .
  66 c . pyindi .  s  . nbpyto . valeurs pour les pyramides                 .
  67 c . pesupp .  s  . nbpeto . support pour les pentaedres                .
  68 c . peindi .  s  . nbpeto . valeurs pour les pentaedres                .
  69 c . nbvapr . e   .   1    . nombre de valeurs du profil                .
  70 c .        .     .        . -1, si pas de profil                       .
  71 c . listpr . e   .   *    . liste des numeros d'elements ou l'indica-  .
  72 c .        .     .        . teur est defini.                           .
  73 c . nbtafo . e   .   1    . nombre de tableaux dans la fonction        .
  74 c . nbvind . e   .   1    . nombre d'entites maximum                   .
  75 c . indica . e   . nbtafo . valeurs de l'indicateur                    .
  76 c .        .     .*nbvind .                                            .
  77 c . ncmpin . e   .   1    . nombre de composantes retenues             .
  78 c . nucomp . e   . ncmpin . numeros des composantes retenues           .
  79 c . nnovho . e   . rvnoto . numero des noeuds dans homard              .
  80 c . narvho . e   . rvarac . numero des aretes dans homard              .
  81 c . ntrvho . e   . rvtrac . numero des triangles dans HOMARD           .
  82 c . nquvho . e   . rvquac . numero des quadrangles dans HOMARD         .
  83 c . ntevho . e   . rvteac . numero des tetraedres dans HOMARD          .
  84 c . nhevho . e   . rvheac . numero des hexaedres dans HOMARD           .
  85 c . npyvho . e   . rvpyac . numero des pyramides dans HOMARD           .
  86 c . npevho . e   . rvpeac . numero des pentaedres dans HOMARD          .
  87 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  88 c . langue . e   .    1   . langue des messages                        .
  89 c .        .     .        . 1 : francais, 2 : anglais                  .
  90 c . codret . es  .    1   . code de retour des modules                 .
  91 c .        .     .        . 0 : pas de probleme                        .
  92 c .        .     .        . 3 : probleme dans les fichiers             .
  93 c ______________________________________________________________________
  94 c
  95 c====
  96 c 0. declarations et dimensionnement
  97 c====
  98 c
  99 c 0.1. ==> generalites
 100 c
 101       implicit none
 102       save
 103 c
 104       character*6 nompro
 105       parameter ( nompro = 'VCINRR' )
 106 c
 107 #include "nblang.h"
 108 c
 109 c 0.2. ==> communs
 110 c
 111 #include "envex1.h"
 112 c
 113 #include "impr02.h"
 114 #include "nombno.h"
 115 #include "nombar.h"
 116 #include "nombtr.h"
 117 #include "nombqu.h"
 118 #include "nombte.h"
 119 #include "nombhe.h"
 120 #include "nombpy.h"
 121 #include "nombpe.h"
 122 c
 123 c 0.3. ==> arguments
 124 c
 125       integer nbvent(-1:7)
 126       integer nosupp(nbnoto)
 127       integer arsupp(nbarto)
 128       integer trsupp(nbtrto)
 129       integer qusupp(nbquto)
 130       integer tesupp(nbteto)
 131       integer hesupp(nbheto)
 132       integer pysupp(nbpyto)
 133       integer pesupp(nbpeto)
 134       integer nbvapr
 135       integer nbtafo, nbvind
 136       integer ncmpin, nucomp(ncmpin)
 137       integer listpr(*)
 138 c
 139       integer nnovho(*)
 140       integer narvho(*)
 141       integer ntrvho(*)
 142       integer nquvho(*)
 143       integer ntevho(*)
 144       integer nhevho(*)
 145       integer npyvho(*)
 146       integer npevho(*)
 147 c
 148       integer ulsort, langue, codret
 149 c
 150       double precision noindi(nbnoto,ncmpin), arindi(nbarto,ncmpin)
 151       double precision trindi(nbtrto,ncmpin), quindi(nbquto,ncmpin)
 152       double precision teindi(nbteto,ncmpin), heindi(nbheto,ncmpin)
 153       double precision pyindi(nbpyto,ncmpin), peindi(nbpeto,ncmpin)
 154       double precision indica(nbtafo,nbvind)
 155 c
 156 c 0.4. ==> variables locales
 157 c
 158       integer iaux
 159 c
 160       integer nbmess
 161       parameter ( nbmess = 10 )
 162       character*80 texte(nblang,nbmess)
 163 c
 164 c 0.5. ==> initialisations
 165 c ______________________________________________________________________
 166 c
 167 c====
 168 c 1. initialisations
 169 c====
 170 c
 171 #include "impr01.h"
 172 c
 173 #ifdef _DEBUG_HOMARD_
 174       write (ulsort,texte(langue,1)) 'Entree', nompro
 175       call dmflsh (iaux)
 176 #endif
 177 c
 178       texte(1,4) = '(''. Indicateur d''''erreur sur les '',i10,1x,a)'
 179 c
 180       texte(2,4) = '(''. Error indicator over '',i10,1x,a)'
 181 c
 182 #include "impr03.h"
 183 c
 184 cgn        do 111 , iaux = 1 , nbtafo
 185 cgn        do 111 , jaux = 1 , nbvind
 186 cgn          write (ulsort,90124) 'indica',iaux,jaux,indica(iaux,jaux)
 187 cgn 111    continue
 188 cgn        do 112 , iaux = 1 , rvtrac
 189 cgn         write (ulsort,90112) 'ntrvho',iaux,ntrvho(iaux)
 190 cgn 112    continue
 191 cgn      print *, 'dans ',nompro,', tyelho, nbvapr = ',tyelho, nbvapr
 192 cgn      print *, 'dans ',nompro,', nbtafo,nbvind = ',nbtafo,nbvind
 193 c
 194 c====
 195 c 2. conversion selon le type d'entite
 196 c====
 197 c
 198 c 2.1. ==> au moins un indicateur est exprime sur les tetraedres
 199 c
 200       iaux = 3
 201       if ( nbvent(iaux).gt.0 ) then
 202 c
 203 #ifdef _DEBUG_HOMARD_
 204         write (ulsort,texte(langue,4)) nbteto, mess14(langue,3,iaux)
 205 #endif
 206 #ifdef _DEBUG_HOMARD_
 207         write (ulsort,texte(langue,3)) 'VCINR1_te', nompro
 208 #endif
 209         call vcinr1 ( nbteto, nbvent(iaux), nbvapr,
 210      >                nbtafo, nbvind, ncmpin, nucomp,
 211      >                indica, ntevho, listpr,
 212      >                tesupp, teindi,
 213      >                ulsort, langue, codret)
 214 c
 215       endif
 216 c
 217 c 2.2. ==> au moins un indicateur est exprime sur les quadrangles
 218 c
 219       iaux = 4
 220       if ( nbvent(iaux).gt.0 ) then
 221 c
 222 #ifdef _DEBUG_HOMARD_
 223         write (ulsort,texte(langue,4)) nbquto, mess14(langue,3,iaux)
 224 #endif
 225 #ifdef _DEBUG_HOMARD_
 226         write (ulsort,texte(langue,3)) 'VCINR1_qu', nompro
 227 #endif
 228         call vcinr1 ( nbquto, nbvent(iaux), nbvapr,
 229      >                nbtafo, nbvind, ncmpin, nucomp,
 230      >                indica, nquvho, listpr,
 231      >                qusupp, quindi,
 232      >                ulsort, langue, codret)
 233 c
 234       endif
 235 c
 236 c 2.3. ==> au moins un indicateur est exprime sur les triangles
 237 c
 238       iaux = 2
 239       if ( nbvent(iaux).gt.0 ) then
 240 c
 241 #ifdef _DEBUG_HOMARD_
 242         write (ulsort,texte(langue,4)) nbtrto, mess14(langue,3,iaux)
 243 #endif
 244 #ifdef _DEBUG_HOMARD_
 245         write (ulsort,texte(langue,3)) 'VCINR1_tr', nompro
 246 #endif
 247         call vcinr1 ( nbtrto, nbvent(iaux), nbvapr,
 248      >                nbtafo, nbvind, ncmpin, nucomp,
 249      >                indica, ntrvho, listpr,
 250      >                trsupp, trindi,
 251      >                ulsort, langue, codret)
 252 c
 253       endif
 254 c
 255 c 2.4. ==> au moins un indicateur est exprime sur les aretes
 256 c
 257       iaux = 1
 258       if ( nbvent(iaux).gt.0 ) then
 259 c
 260 #ifdef _DEBUG_HOMARD_
 261         write (ulsort,texte(langue,4)) nbarto, mess14(langue,3,iaux)
 262 #endif
 263 #ifdef _DEBUG_HOMARD_
 264         write (ulsort,texte(langue,3)) 'VCINR1_ar', nompro
 265 #endif
 266         call vcinr1 ( nbarto, nbvent(iaux), nbvapr,
 267      >                nbtafo, nbvind, ncmpin, nucomp,
 268      >                indica, narvho, listpr,
 269      >                arsupp, arindi,
 270      >                ulsort, langue, codret)
 271 c
 272       endif
 273 c
 274 c 2.5. ==> au moins un indicateur est exprime sur les noeuds
 275 c
 276       iaux = -1
 277       if ( nbvent(iaux).gt.0 ) then
 278 c
 279 #ifdef _DEBUG_HOMARD_
 280         write (ulsort,texte(langue,4)) nbnoto, mess14(langue,3,iaux)
 281 #endif
 282 #ifdef _DEBUG_HOMARD_
 283         write (ulsort,texte(langue,3)) 'VCINR1_no', nompro
 284 #endif
 285         call vcinr1 ( nbnoto, nbvent(iaux), nbvapr,
 286      >                nbtafo, nbvind, ncmpin, nucomp,
 287      >                indica, nnovho, listpr,
 288      >                nosupp, noindi,
 289      >                ulsort, langue, codret)
 290 c
 291       endif
 292 c
 293 c 2.5. ==> au moins un indicateur est exprime sur les pyramides
 294 c
 295       iaux = 5
 296       if ( nbvent(iaux).gt.0 ) then
 297 c
 298 #ifdef _DEBUG_HOMARD_
 299         write (ulsort,texte(langue,4)) nbpyto, mess14(langue,3,iaux)
 300 #endif
 301 #ifdef _DEBUG_HOMARD_
 302         write (ulsort,texte(langue,3)) 'VCINR1_py', nompro
 303 #endif
 304         call vcinr1 ( nbpyto, nbvent(iaux), nbvapr,
 305      >                nbtafo, nbvind, ncmpin, nucomp,
 306      >                indica, npyvho, listpr,
 307      >                pysupp, pyindi,
 308      >                ulsort, langue, codret)
 309 c
 310       endif
 311 c
 312 c 2.6. ==> au moins un indicateur est exprime sur les hexaedres
 313 c
 314       iaux = 6
 315       if ( nbvent(iaux).gt.0 ) then
 316 c
 317 #ifdef _DEBUG_HOMARD_
 318         write (ulsort,texte(langue,4)) nbheto, mess14(langue,3,iaux)
 319 #endif
 320 #ifdef _DEBUG_HOMARD_
 321         write (ulsort,texte(langue,3)) 'VCINR1_he', nompro
 322 #endif
 323         call vcinr1 ( nbheto, nbvent(iaux), nbvapr,
 324      >                nbtafo, nbvind, ncmpin, nucomp,
 325      >                indica, nhevho, listpr,
 326      >                hesupp, heindi,
 327      >                ulsort, langue, codret)
 328 c
 329       endif
 330 c
 331 c 2.7. ==> au moins un indicateur est exprime sur les pentaedres
 332 c
 333       iaux = 7
 334       if ( nbvent(iaux).gt.0 ) then
 335 c
 336 #ifdef _DEBUG_HOMARD_
 337         write (ulsort,texte(langue,4)) nbheto, mess14(langue,3,iaux)
 338 #endif
 339 #ifdef _DEBUG_HOMARD_
 340         write (ulsort,texte(langue,3)) 'VCINR1_pe', nompro
 341 #endif
 342         call vcinr1 ( nbpeto, nbvent(iaux), nbvapr,
 343      >                nbtafo, nbvind, ncmpin, nucomp,
 344      >                indica, npevho, listpr,
 345      >                pesupp, peindi,
 346      >                ulsort, langue, codret)
 347 c
 348       endif
 349 c
 350 c====
 351 c 3. la fin
 352 c====
 353 c
 354       if ( codret.ne.0 ) then
 355 c
 356 #include "envex2.h"
 357 c
 358       write (ulsort,texte(langue,1)) 'Sortie', nompro
 359       write (ulsort,texte(langue,2)) codret
 360 c
 361       endif
 362 c
 363 #ifdef _DEBUG_HOMARD_
 364       write (ulsort,texte(langue,1)) 'Sortie', nompro
 365       call dmflsh (iaux)
 366 #endif
 367 c
 368       end