src/tool/Suivi_Frontiere/sfcona.F

   1       subroutine sfcona ( option, nbarfr, arefro,
   2      >                    hetare, cfaare, famare,
   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 d'Aretes
  24 c   -        -           --         -        -
  25 c ______________________________________________________________________
  26 c .        .     .        .                                            .
  27 c .  nom   . e/s . taille .           description                      .
  28 c .____________________________________________________________________.
  29 c . otpion . e   .   1    . type de recherche :                        .
  30 c .        .     .        . 0 : toutes les aretes actives              .
  31 c .        .     .        . 1 : les actives qui viennent d'etre coupees.
  32 c . nbarfr . es  .   1    . si 0 : on cherche le nombre, on le renvoie .
  33 c .        .     .        . sinon, on remplit                          .
  34 c . arefro .  s  . nbarfr . numeros des aretes  concernees             .
  35 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  36 c . cfaare . e   . nctfar*. codes des familles des aretes              .
  37 c .        .     . nbfare .   1 : famille MED                          .
  38 c .        .     .        .   2 : type de segment                      .
  39 c .        .     .        .   3 : orientation                          .
  40 c .        .     .        .   4 : famille d'orientation inverse        .
  41 c .        .     .        .   5 : numero de ligne de frontiere         .
  42 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
  43 c .        .     .        . <= 0 si non concernee                      .
  44 c .        .     .        .   6 : famille frontiere active/inactive    .
  45 c .        .     .        .   7 : numero de surface de frontiere       .
  46 c .        .     .        . + l : appartenance a l'equivalence l       .
  47 c . famare . e   . nbarto . famille des aretes                         .
  48 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  49 c . langue . e   .    1   . langue des messages                        .
  50 c .        .     .        . 1 : francais, 2 : anglais                  .
  51 c . codret . es  .    1   . code de retour des modules                 .
  52 c .        .     .        . 0 : pas de probleme                        .
  53 c .        .     .        . x : probleme                               .
  54 c ______________________________________________________________________
  55 c
  56 c====
  57 c 0. declarations et dimensionnement
  58 c====
  59 c
  60 c 0.1. ==> generalites
  61 c
  62       implicit none
  63       save
  64 c
  65       character*6 nompro
  66       parameter ( nompro = 'SFCONA' )
  67 c
  68 #include "nblang.h"
  69 #include "cofaar.h"
  70 c
  71 c 0.2. ==> communs
  72 c
  73 #include "envex1.h"
  74 c
  75 #include "dicfen.h"
  76 #include "nbfami.h"
  77 #include "nombar.h"
  78 #include "impr02.h"
  79 c
  80 c 0.3. ==> arguments
  81 c
  82       integer option
  83       integer nbarfr
  84       integer arefro(nbarfr)
  85       integer hetare(nbarto)
  86       integer cfaare(nctfar,nbfare), famare(nbarto)
  87 c
  88       integer ulsort, langue, codret
  89 c
  90 c 0.4. ==> variables locales
  91 c
  92       integer iaux, jaux
  93       integer etat01, etat02
  94 c
  95       integer nbmess
  96       parameter ( nbmess = 10 )
  97       character*80 texte(nblang,nbmess)
  98 c
  99 c 0.5. ==> initialisations
 100 c ______________________________________________________________________
 101 c
 102 c====
 103 c 1. Prealables
 104 c====
 105 c 1.1. ==> Les messages
 106 c
 107 #include "impr01.h"
 108 c
 109 #ifdef _DEBUG_HOMARD_
 110       write (ulsort,texte(langue,1)) 'Entree', nompro
 111       call dmflsh (iaux)
 112 #endif
 113 c
 114       texte(1,4) = '(''Examen de toutes les entites.'')'
 115       texte(1,5) = '(''Examen des entites decoupees.'')'
 116       texte(1,6) = '(''Option incorrecte :'',i10)'
 117       texte(1,7) = '(''Aucun '',a,''n''''est concerne.'')'
 118       texte(1,8) = '(''Nombre de '',a,''concernes :'',i10)'
 119 c
 120       texte(2,4) = '(''Examination of all the entities.'')'
 121       texte(2,5) = '(''Examination of cut entities.'')'
 122       texte(2,6) = '(''Non valid option :'',i10)'
 123       texte(2,7) = '(''No '',a,''is involved'')'
 124       texte(2,8) = '(''Number of involved '',a,'':'',i10)'
 125 c
 126 c 1.2. ==> Initialisations
 127 c
 128       codret = 0
 129 c
 130       if ( option.eq.0 ) then
 131         etat01 = 0
 132         etat02 = 2
 133       elseif ( option.eq.1 ) then
 134         etat01 = 2
 135         etat02 = 2
 136       else
 137         write (ulsort,texte(langue,6)) option
 138         codret = 1
 139       endif
 140 c
 141 #ifdef _DEBUG_HOMARD_
 142       if ( codret.eq.0 ) then
 143         write (ulsort,texte(langue,4+option))
 144       endif
 145 #endif
 146 c
 147 c====
 148 c 2. Decompte des aretes
 149 c    On ne s'interesse qu'aux aretes :
 150 c    . qui font partie d'une frontiere reconnue
 151 c    . qui viennent d'etre decoupees
 152 c====
 153 c
 154       if ( nbarfr.eq.0 ) then
 155 c
 156 #ifdef _DEBUG_HOMARD_
 157       write (ulsort,*) '2. Decompte aretes ; codret = ', codret
 158 #endif
 159 c
 160       do 21 , iaux = 1 , nbarto
 161 c
 162         if ( codret.eq.0 ) then
 163 c
 164         if ( cfaare(cosfsa,famare(iaux)).gt.0 .or.
 165      >       cfaare(cosfli,famare(iaux)).gt.0 ) then
 166 c
 167           if ( hetare(iaux).eq.etat01 .or.
 168      >         hetare(iaux).eq.etat02 ) then
 169 c
 170 cgn      write (ulsort,*) 'arete ',iaux,cfaare(cosfsa,famare(iaux)),
 171 cgn     >         cfaare(cosfli,famare(iaux))
 172             nbarfr = nbarfr + 1
 173 c
 174           endif
 175 c
 176         endif
 177 c
 178         endif
 179 c
 180    21 continue
 181 c
 182 #ifdef _DEBUG_HOMARD_
 183       if ( codret.eq.0 ) then
 184       if ( nbarfr.eq.0 ) then
 185         write (ulsort,texte(langue,7)) mess14(langue,1,1)
 186       else
 187         write (ulsort,texte(langue,8)) mess14(langue,3,1), nbarfr
 188       endif
 189       endif
 190 #endif
 191 c
 192 c====
 193 c 3. Remplissage
 194 c====
 195 c
 196       else
 197 c
 198 #ifdef _DEBUG_HOMARD_
 199       write (ulsort,*) '3. Remplissage ; codret = ', codret
 200 #endif
 201 c
 202       jaux = 0
 203 c
 204       do 31 , iaux = 1 , nbarto
 205 c
 206         if ( codret.eq.0 ) then
 207 c
 208         if ( cfaare(cosfsa,famare(iaux)).gt.0 .or.
 209      >       cfaare(cosfli,famare(iaux)).gt.0 ) then
 210 c
 211           if ( hetare(iaux).eq.etat01 .or.
 212      >         hetare(iaux).eq.etat02 ) then
 213 c
 214 cgn      write (ulsort,*) 'arete ',iaux,cfaare(cosfsa,famare(iaux)),
 215 cgn     >         cfaare(cosfli,famare(iaux))
 216 c
 217             jaux = jaux + 1
 218             arefro(jaux) = iaux
 219 c
 220           endif
 221 c
 222         endif
 223 c
 224         endif
 225 c
 226    31 continue
 227 c
 228 c reactualisation du nombre d'aretes concernees : certaines ont
 229 c disparu car elles sont sur des lignes droites
 230 c
 231       nbarfr = jaux
 232 c
 233 #ifdef _DEBUG_HOMARD_
 234       if ( codret.eq.0 ) then
 235       if ( nbarfr.eq.0 ) then
 236         write (ulsort,texte(langue,7)) mess14(langue,1,1)
 237       else
 238         write (ulsort,texte(langue,8)) mess14(langue,3,1), nbarfr
 239       endif
 240       endif
 241 #endif
 242 c
 243       endif
 244 c
 245 c====
 246 c 4. La fin
 247 c====
 248 c
 249       if ( codret.ne.0 ) then
 250 c
 251 #include "envex2.h"
 252 c
 253       write (ulsort,texte(langue,1)) 'Sortie', nompro
 254       write (ulsort,texte(langue,2)) codret
 255 c
 256       endif
 257 c
 258 #ifdef _DEBUG_HOMARD_
 259       write (ulsort,texte(langue,1)) 'Sortie', nompro
 260       call dmflsh (iaux)
 261 #endif
 262 c
 263       end