src/tool/Suivi_Frontiere/sfcovo.F

   1       subroutine sfcovo ( bilan,
   2      >                    nbtetr, nbhexa, nbpyra, nbpent,
   3      >                    decafv, volare,
   4      >                    coonoe,
   5      >                    somare,
   6      >                    aretri,
   7      >                    arequa,
   8      >                    tritet, cotrte, aretet,
   9      >                    hettet, filtet,
  10      >                    quahex, coquhe, arehex,
  11      >                    hethex, filhex,
  12      >                    ulsort, langue, codret)
  13 c ______________________________________________________________________
  14 c                             H O M A R D
  15 c
  16 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  17 c
  18 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  19 c aupres des huissiers de justice Simart et Lavoir a Clamart
  20 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  21 c aupres des huissiers de justice
  22 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  23 c
  24 c    HOMARD est une marque deposee d'Electricite de France
  25 c
  26 c Copyright EDF 1996
  27 c Copyright EDF 1998
  28 c Copyright EDF 2002
  29 c Copyright EDF 2020
  30 c ______________________________________________________________________
  31 c
  32 c   Suivi de Frontiere - COntroles des VOlumes
  33 c   -        -           --            --
  34 c ______________________________________________________________________
  35 c .        .     .        .                                            .
  36 c .  nom   . e/s . taille .           description                      .
  37 c .____________________________________________________________________.
  38 c . bilan  .   s .   1    . bilan du controle de l'arete               .
  39 c .        .     .        . 0 : pas de probleme                        .
  40 c .        .     .        . 1 : probleme                               .
  41 c . nbtetr . e   .   1    . nombre de tetraedres voisins               .
  42 c . nbhexa . e   .   1    . nombre d'hexaedres voisins                 .
  43 c . nbpyra . e   .   1    . nombre de pyramides voisines               .
  44 c . nbpent . e   .   1    . nombre de pentaedres voisins               .
  45 c . decafv . e   .   1    . decalage dans le tableau volare            .
  46 c . volare . e   .   *    . liste des voisins                          .
  47 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  48 c .        .     . *sdim  .                                            .
  49 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  50 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  51 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  52 c . tritet . e   .nbtecf*4. numeros des triangles des tetraedres       .
  53 c . cotrte . e   .nbtecf*4. codes des triangles des tetraedres         .
  54 c . aretet . e   .nbteca*6. numeros des 6 aretes des tetraedres        .
  55 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  56 c . filtet . e   . nbteto . premier fils des tetraedres                .
  57 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  58 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  59 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
  60 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  61 c . filhex . e   . nbheto . premier fils des hexaedres                 .
  62 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  63 c . langue . e   .    1   . langue des messages                        .
  64 c .        .     .        . 1 : francais, 2 : anglais                  .
  65 c . codret . es  .    1   . code de retour des modules                 .
  66 c .        .     .        . 0 : pas de probleme                        .
  67 c .        .     .        . x : probleme                               .
  68 c ______________________________________________________________________
  69 c
  70 c====
  71 c 0. declarations et dimensionnement
  72 c====
  73 c
  74 c 0.1. ==> generalites
  75 c
  76       implicit none
  77       save
  78 c
  79       character*6 nompro
  80       parameter ( nompro = 'SFCOVO' )
  81 c
  82 #include "nblang.h"
  83 c
  84 c 0.2. ==> communs
  85 c
  86 #include "envex1.h"
  87 c
  88 #include "envca1.h"
  89 #include "nombno.h"
  90 #include "nombar.h"
  91 #include "nombqu.h"
  92 #include "nombtr.h"
  93 #include "nombte.h"
  94 #include "nombhe.h"
  95 #include "impr02.h"
  96 c
  97 c 0.3. ==> arguments
  98 c
  99       integer bilan
 100       integer nbtetr, nbhexa, nbpyra, nbpent
 101       integer decafv, volare(*)
 102 c
 103       integer somare(2,nbarto)
 104       integer aretri(nbtrto,3)
 105       integer arequa(nbquto,4)
 106       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
 107       integer hettet(nbteto), filtet(nbteto)
 108       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
 109       integer hethex(nbheto), filhex(nbheto)
 110 c
 111       double precision coonoe(nbnoto,sdim)
 112 c
 113       integer ulsort, langue, codret
 114 c
 115 c 0.4. ==> variables locales
 116 c
 117       integer iaux
 118 c
 119       integer nbmess
 120       parameter ( nbmess = 10 )
 121       character*80 texte(nblang,nbmess)
 122 c
 123 c 0.5. ==> initialisations
 124 c ______________________________________________________________________
 125 c
 126 c====
 127 c 1. messages
 128 c====
 129 c
 130 #include "impr01.h"
 131 c
 132 #ifdef _DEBUG_HOMARD_
 133       write (ulsort,texte(langue,1)) 'Entree', nompro
 134       call dmflsh (iaux)
 135 #endif
 136 c
 137       texte(1,4) = '(/,''.. Examen du '',a,i10)'
 138       texte(1,5) = '(''.. Probleme.'')'
 139       texte(1,6) = '(''.. Nombre de voisins de type '',a,'':'',i10)'
 140 c
 141       texte(2,4) = '(/,''.. Examination of '',a,'' # '',i10)'
 142       texte(2,5) = '(''.. Problem.'')'
 143       texte(2,6) = '(''.. Number of neighbours '',a,''type :'',i10)'
 144 c
 145 #include "impr03.h"
 146 c
 147 c====
 148 c 3. Controle des tetraedres
 149 c====
 150
 151 #ifdef _DEBUG_HOMARD_
 152       write (ulsort,90002) '3. Controle tetraedres ; codret', codret
 153 #endif
 154 c
 155       if ( codret.eq.0 ) then
 156 c
 157 #ifdef _DEBUG_HOMARD_
 158       write (ulsort,texte(langue,6)) mess14(langue,1,3), nbtetr
 159 #endif
 160 c
 161       do 31 , iaux = 1 , nbtetr
 162 c
 163         if ( codret.eq.0 ) then
 164 c
 165 #ifdef _DEBUG_HOMARD_
 166       write (ulsort,texte(langue,4)) mess14(langue,1,3), volare(iaux)
 167 #endif
 168 c
 169 #ifdef _DEBUG_HOMARD_
 170       write (ulsort,texte(langue,3)) 'UTCOTE', nompro
 171 #endif
 172         call utcote ( volare(iaux), bilan,
 173      >                coonoe,
 174      >                somare,
 175      >                aretri,
 176      >                tritet, cotrte, aretet,
 177      >                hettet, filtet,
 178      >                ulsort, langue, codret)
 179 c
 180         endif
 181 c
 182         if ( codret.eq.0 ) then
 183 c
 184         if ( bilan.ne.0 ) then
 185           goto 70
 186         endif
 187 c
 188         endif
 189 c
 190    31 continue
 191 c
 192       endif
 193 c
 194 c====
 195 c 4. Controle des hexaedres
 196 c====
 197 #ifdef _DEBUG_HOMARD_
 198       write (ulsort,90002) '4. Controle hexaedres ; codret', codret
 199 #endif
 200 c
 201       if ( codret.eq.0 ) then
 202 c
 203 #ifdef _DEBUG_HOMARD_
 204       write (ulsort,texte(langue,6)) mess14(langue,1,6), nbhexa
 205 #endif
 206 c
 207       do 41 , iaux = 1 , nbhexa
 208 c
 209         if ( codret.eq.0 ) then
 210 ccc        if ( volare(decafv+iaux).ne.49 ) goto 41
 211 c
 212 #ifdef _DEBUG_HOMARD_
 213       write (ulsort,texte(langue,4))
 214      >                    mess14(langue,1,6), volare(decafv+iaux)
 215 #endif
 216 c
 217 #ifdef _DEBUG_HOMARD_
 218       write (ulsort,texte(langue,3)) 'UTCOHE', nompro
 219 #endif
 220         call utcohe ( volare(decafv+iaux), bilan,
 221      >                coonoe,
 222      >                somare,
 223      >                arequa,
 224      >                quahex, coquhe, arehex,
 225      >                hethex, filhex,
 226      >                ulsort, langue, codret)
 227 c
 228         endif
 229 c
 230         if ( codret.eq.0 ) then
 231 c
 232         if ( bilan.ne.0 ) then
 233           goto 70
 234         endif
 235 c
 236         endif
 237 c
 238    41 continue
 239 c
 240       endif
 241 c
 242 c====
 243 c 5. Controle des pyramides
 244 c====
 245 #ifdef _DEBUG_HOMARD_
 246       write (ulsort,90002) '5. Controle pyramides ; codret', codret
 247 #endif
 248 c
 249       if ( codret.eq.0 ) then
 250 c
 251 #ifdef _DEBUG_HOMARD_
 252       write (ulsort,texte(langue,6)) mess14(langue,1,5), nbpyra
 253 #endif
 254 c
 255       do 51 , iaux = 1 , nbpyra
 256 c
 257         if ( codret.eq.0 ) then
 258 c
 259 #ifdef _DEBUG_HOMARD_
 260       write (ulsort,texte(langue,4))
 261      >                    mess14(langue,1,5), volare(2*decafv+iaux)
 262 #endif
 263 c
 264         if ( codret.eq.0 ) then
 265 c
 266         if ( bilan.ne.0 ) then
 267           goto 70
 268         endif
 269 c
 270         endif
 271 c
 272         endif
 273 c
 274    51 continue
 275 c
 276       endif
 277 c
 278 c====
 279 c 6. Controle des pentaedres
 280 c====
 281 #ifdef _DEBUG_HOMARD_
 282       write (ulsort,90002) '6. Controle pentaedres ; codret', codret
 283 #endif
 284 c
 285       if ( codret.eq.0 ) then
 286 c
 287 #ifdef _DEBUG_HOMARD_
 288       write (ulsort,texte(langue,6)) mess14(langue,1,7), nbpent
 289 #endif
 290 c
 291       do 61 , iaux = 1 , nbpent
 292 c
 293         if ( codret.eq.0 ) then
 294 c
 295 #ifdef _DEBUG_HOMARD_
 296       write (ulsort,texte(langue,4))
 297      >                    mess14(langue,1,7), volare(3*decafv+iaux)
 298 #endif
 299 c
 300         if ( codret.eq.0 ) then
 301 c
 302         if ( bilan.ne.0 ) then
 303           goto 70
 304         endif
 305 c
 306         endif
 307 c
 308         endif
 309 c
 310    61 continue
 311 c
 312       endif
 313 c
 314 c====
 315 c 7. Bilan
 316 c====
 317 c
 318 #ifdef _DEBUG_HOMARD_
 319       write (ulsort,90002) '7. Bilan ; codret', codret
 320 #endif
 321 c
 322    70 continue
 323 c
 324 #ifdef _DEBUG_HOMARD_
 325       if ( codret.eq.0 ) then
 326       if ( bilan.ne.0 ) then
 327         write (ulsort,texte(langue,5))
 328       endif
 329       endif
 330 #endif
 331 c
 332 c====
 333 c 8. La fin
 334 c====
 335 c
 336       if ( codret.ne.0 ) then
 337 c
 338 #include "envex2.h"
 339 c
 340       write (ulsort,texte(langue,1)) 'Sortie', nompro
 341       write (ulsort,texte(langue,2)) codret
 342 c
 343       endif
 344 c
 345 #ifdef _DEBUG_HOMARD_
 346       write (ulsort,texte(langue,1)) 'Sortie', nompro
 347       call dmflsh (iaux)
 348 #endif
 349 c
 350       end