src/tool/Suivi_Frontiere/sfconq.F

   1       subroutine sfconq ( option, nbqufr, quafro,
   2      >                    hetqua, cfaqua, famqua,
   3      >                    ulsort, langue, codret)
   4 c ______________________________________________________________________
   5 c                             H O M A R D
   6 c
   7 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   8 c
   9 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  10 c aupres des huissiers de justice Simart et Lavoir a Clamart
  11 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  12 c aupres des huissiers de justice
  13 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  14 c
  15 c    HOMARD est une marque deposee d'Electricite de France
  16 c
  17 c Copyright EDF 1996
  18 c Copyright EDF 1998
  19 c Copyright EDF 2002
  20 c Copyright EDF 2020
  21 c ______________________________________________________________________
  22 c
  23 c   Suivi de Frontiere - COntrole - Nombre de Quadrangles
  24 c   -        -           --         -         -
  25 c ______________________________________________________________________
  26 c .        .     .        .                                            .
  27 c .  nom   . e/s . taille .           description                      .
  28 c .____________________________________________________________________.
  29 c . option . e   .   1    . type de recherche :                        .
  30 c .        .     .        . 0 : tous les quadrangles actifs            .
  31 c .        .     .        . 1 : les actifs qui viennent d'etre coupes  .
  32 c . nbqufr . es  .   1    . si 0 : on cherche le nombre, on le renvoie .
  33 c .        .     .        . sinon, on remplit                          .
  34 c . quafro .  s  . nbqufr . numeros des quadrangles concernes          .
  35 c . hetqua . e   . nbquto . historique de l'etat des aretes            .
  36 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
  37 c .        .     . nbfqua .   1 : famille MED                          .
  38 c .        .     .        .   2 : type de quadrangle                   .
  39 c .        .     .        .   3 : numero de surface de frontiere       .
  40 c .        .     .        .   4 : famille des aretes internes apres raf.
  41 c .        .     .        .   5 : famille des triangles de conformite  .
  42 c .        .     .        .   6 : famille de sf active/inactive        .
  43 c .        .     .        . + l : appartenance a l'equivalence l       .
  44 c . famqua . e   . nbquto . famille des quadrangles                    .
  45 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  46 c . langue . e   .    1   . langue des messages                        .
  47 c .        .     .        . 1 : francais, 2 : anglais                  .
  48 c . codret . es  .    1   . code de retour des modules                 .
  49 c .        .     .        . 0 : pas de probleme                        .
  50 c .        .     .        . x : probleme                               .
  51 c ______________________________________________________________________
  52 c
  53 c====
  54 c 0. declarations et dimensionnement
  55 c====
  56 c
  57 c 0.1. ==> generalites
  58 c
  59       implicit none
  60       save
  61 c
  62       character*6 nompro
  63       parameter ( nompro = 'SFCONQ' )
  64 c
  65 #include "nblang.h"
  66 #include "cofatq.h"
  67 c
  68 c 0.2. ==> communs
  69 c
  70 #include "envex1.h"
  71 c
  72 #include "dicfen.h"
  73 #include "nbfami.h"
  74 #include "nombqu.h"
  75 #include "impr02.h"
  76 c
  77 c 0.3. ==> arguments
  78 c
  79       integer option
  80       integer nbqufr
  81       integer quafro(nbqufr)
  82       integer hetqua(nbquto)
  83       integer cfaqua(nctfqu,nbfqua), famqua(nbquto)
  84 c
  85       integer ulsort, langue, codret
  86 c
  87 c 0.4. ==> variables locales
  88 c
  89       integer iaux, jaux
  90       integer etat01, etat02
  91       integer etan, etanp1
  92 c
  93       integer nbmess
  94       parameter ( nbmess = 10 )
  95       character*80 texte(nblang,nbmess)
  96 c
  97 c 0.5. ==> initialisations
  98 c ______________________________________________________________________
  99 c
 100 c====
 101 c 1. Prealables
 102 c====
 103 c 1.1. ==> Les messages
 104 c
 105 #include "impr01.h"
 106 c
 107 #ifdef _DEBUG_HOMARD_
 108       write (ulsort,texte(langue,1)) 'Entree', nompro
 109       call dmflsh (iaux)
 110 #endif
 111 c
 112       texte(1,4) = '(''Examen de toutes les entites.'')'
 113       texte(1,5) = '(''Examen des entites decoupees.'')'
 114       texte(1,6) = '(''Option incorrecte :'',i10)'
 115       texte(1,7) = '(''Aucun '',a,''n''''est concerne.'')'
 116       texte(1,8) = '(''Nombre de '',a,''concernes :'',i10)'
 117 c
 118       texte(2,4) = '(''Examination of all the entities.'')'
 119       texte(2,5) = '(''Examination of cut entities.'')'
 120       texte(2,6) = '(''Non valid option :'',i10)'
 121       texte(2,7) = '(''No '',a,''is involved'')'
 122       texte(2,8) = '(''Number of involved '',a,'':'',i10)'
 123 c
 124 c 1.2. ==> Initialisations
 125 c
 126       codret = 0
 127 c
 128       if ( option.eq.0 ) then
 129         etat01 = 0
 130         etat02 = 4
 131       elseif ( option.eq.1 ) then
 132         etat01 = 4
 133         etat02 = 4
 134       else
 135         write (ulsort,texte(langue,6)) option
 136         codret = 1
 137       endif
 138 c
 139 #ifdef _DEBUG_HOMARD_
 140       if ( codret.eq.0 ) then
 141         write (ulsort,texte(langue,4+option))
 142       endif
 143 #endif
 144 c
 145 c====
 146 c 2. Decompte des quadrangles
 147 c    On ne s'interesse qu'aux quadrangles :
 148 c    . qui font partie d'une frontiere reconnue
 149 c    . qui viennent d'etre decoupes
 150 c====
 151 c
 152       if ( nbqufr.eq.0 ) then
 153 c
 154 #ifdef _DEBUG_HOMARD_
 155       write (ulsort,*) '2. Decompte quadrangles ; codret = ', codret
 156 #endif
 157 c
 158       do 21 , iaux = 1 , nbquto
 159 c
 160         if ( codret.eq.0 ) then
 161 c
 162         if ( cfaqua(cosfsu,famqua(iaux)).gt.0 ) then
 163 c
 164           etanp1 = mod(hetqua(iaux),100)
 165 c
 166           if ( etanp1.eq.etat01 .or. etanp1.eq.etat02 ) then
 167 c
 168             etan = (hetqua(iaux)-etanp1) / 100
 169 c
 170             if ( etan.eq.0 .or. ( etan.ge.31 .and. etan.le.34 ) ) then
 171 c
 172 cgn      write (ulsort,*) 'quad ',iaux,cfaqua(cosfsu,famqua(iaux))
 173               nbqufr = nbqufr + 1
 174 c
 175             endif
 176 c
 177           endif
 178 c
 179         endif
 180 c
 181         endif
 182 c
 183    21 continue
 184 c
 185 #ifdef _DEBUG_HOMARD_
 186       if ( codret.eq.0 ) then
 187       if ( nbqufr.eq.0 ) then
 188         write (ulsort,texte(langue,7)) mess14(langue,1,4)
 189       else
 190         write (ulsort,texte(langue,8)) mess14(langue,3,4), nbqufr
 191       endif
 192       endif
 193 #endif
 194 c
 195 c====
 196 c 3. Remplissage
 197 c====
 198 c
 199       else
 200 c
 201 #ifdef _DEBUG_HOMARD_
 202       write (ulsort,*) '3. Remplissage ; codret = ', codret
 203 #endif
 204 c
 205       jaux = 0
 206 c
 207       do 31 , iaux = 1 , nbquto
 208 c
 209         if ( codret.eq.0 ) then
 210 c
 211         if ( cfaqua(cosfsu,famqua(iaux)).gt.0 ) then
 212 c
 213           etanp1 = mod(hetqua(iaux),100)
 214 c
 215           if ( etanp1.eq.etat01 .or. etanp1.eq.etat02 ) then
 216 c
 217             etan = (hetqua(iaux)-etanp1) / 100
 218 c
 219             if ( etan.eq.0 .or. ( etan.ge.31 .and. etan.le.34 ) ) then
 220 c
 221 cgn      write (ulsort,*) 'quad ',iaux,cfaqua(cosfsu,famqua(iaux))
 222               jaux = jaux + 1
 223               quafro(jaux) = iaux
 224 c
 225             endif
 226 c
 227           endif
 228 c
 229         endif
 230 c
 231         endif
 232 c
 233    31 continue
 234 c
 235 c reactualisation du nombre de quadrangles concernes : certains ont
 236 c disparus car ils sont sur des surfaces planes
 237 c
 238       nbqufr = jaux
 239 c
 240       endif
 241 c
 242 c====
 243 c 4. La fin
 244 c====
 245 c
 246       if ( codret.ne.0 ) then
 247 c
 248 #include "envex2.h"
 249 c
 250       write (ulsort,texte(langue,1)) 'Sortie', nompro
 251       write (ulsort,texte(langue,2)) codret
 252 c
 253       endif
 254 c
 255 #ifdef _DEBUG_HOMARD_
 256       write (ulsort,texte(langue,1)) 'Sortie', nompro
 257       call dmflsh (iaux)
 258 #endif
 259 c
 260       end