src/tool/Suivi_Frontiere/sfnuli.F

   1       subroutine sfnuli ( cfaare, numlig, option,
   2      >                    lgetco, taetco,
   3      >                    ulsort, langue, codret)
   4 c ______________________________________________________________________
   5 c
   6 c                             H O M A R D
   7 c
   8 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   9 c
  10 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  11 c aupres des huissiers de justice Simart et Lavoir a Clamart
  12 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  13 c aupres des huissiers de justice
  14 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  15 c
  16 c    HOMARD est une marque deposee d'Electricite de France
  17 c
  18 c Copyright EDF 1996
  19 c Copyright EDF 1998
  20 c Copyright EDF 2002
  21 c Copyright EDF 2020
  22 c ______________________________________________________________________
  23 c
  24 c   Suivi de Frontiere - NUmeros de LIgne
  25 c   -        -           --         --
  26 c ______________________________________________________________________
  27 c
  28 c but : compactage ou retablissement des numeros de ligne des familles
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . cfaare . e   . nctfar*. codes des familles des aretes              .
  34 c .        .     . nbfare .   1 : famille MED                          .
  35 c .        .     .        .   2 : type de segment                      .
  36 c .        .     .        .   3 : orientation                          .
  37 c .        .     .        .   4 : famille d'orientation inverse        .
  38 c .        .     .        .   5 : numero de ligne de frontiere         .
  39 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
  40 c .        .     .        . <= 0 si non concernee                      .
  41 c .        .     .        .   6 : famille frontiere active/inactive    .
  42 c .        .     .        .   7 : numero de surface de frontiere       .
  43 c .        .     .        . + l : appartenance a l'equivalence l       .
  44 c . numlig . e   . sfnbli . numero des lignes                          .
  45 c . option . e   .   1    . 0 pour compactage, sinon retablissement    .
  46 c . lgetco . e   .   1    . longueur du tableau de l'etat courant      .
  47 c . taetco . e   . lgetco . tableau de l'etat courant                  .
  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 = 'SFNULI' )
  67 c
  68 #include "nblang.h"
  69 #include "cofaar.h"
  70 #include "cofina.h"
  71 c
  72 c 0.2. ==> communs
  73 c
  74 #include "front1.h"
  75 #include "dicfen.h"
  76 #include "nbfami.h"
  77 #include "envex1.h"
  78 c
  79 c 0.3. ==> arguments
  80 c
  81       integer option
  82       integer numlig(sfnbli)
  83       integer cfaare(nctfar,nbfare)
  84 c
  85       integer lgetco
  86       integer taetco(lgetco)
  87 c
  88       integer ulsort, langue, codret
  89 c
  90 c 0.4. ==> variables locales
  91 c
  92       integer nretap, nrsset
  93       integer iaux
  94 c
  95       integer lig, ligv
  96 c
  97       character*6 saux
  98 c
  99       integer nbmess
 100       parameter ( nbmess = 10 )
 101       character*80 texte(nblang,nbmess)
 102 c
 103 c 0.5. ==> initialisations
 104 c ______________________________________________________________________
 105 c
 106 c====
 107 c 1. messages
 108 c====
 109 c
 110 c 1.1. ==> les messages
 111 c
 112 #include "impr01.h"
 113 c
 114 #ifdef _DEBUG_HOMARD_
 115       write (ulsort,texte(langue,1)) 'Entree', nompro
 116       call dmflsh (iaux)
 117 #endif
 118 c
 119       texte(1,4) = '(/,a6,'' COMPACTAGE DES NUMEROS DE LIGNE'')'
 120       texte(1,5) = '(38(''=''),/)'
 121       texte(1,6) = '(/,a6,'' RESTITUTION DE NUMEROS DE LIGNE'')'
 122       texte(1,7) =
 123      > '(5x,''La ligne'',i10,'' ne figure pas dans la liste :'')'
 124 c
 125       texte(2,4) = '(/,a6,'' LINE NUMBERS COMPACTING'')'
 126       texte(2,5) = '(30(''=''),/)'
 127       texte(2,6) = '(/,a6,'' LINE NUMBERS RETRIEVING'')'
 128       texte(2,7) =
 129      > '(5x,''Line #'',i10,'' does not belong to list:'')'
 130 c
 131 #include "impr03.h"
 132 c
 133 c 1.2. ==> le numero de sous-etape
 134 c
 135       nretap = taetco(1)
 136       nrsset = taetco(2) + 1
 137       taetco(2) = nrsset
 138 c
 139       call utcvne ( nretap, nrsset, saux, iaux, codret )
 140 c
 141 c 1.3. ==> le titre
 142 c
 143       if ( option.eq.0 ) then
 144         write (ulsort,texte(langue,4)) saux
 145       else
 146         write (ulsort,texte(langue,6)) saux
 147       endif
 148       write (ulsort,texte(langue,5))
 149 c
 150 c====
 151 c 2. boucle sur les familles d'aretes : compacter les numeros
 152 c====
 153 c
 154       if ( option.eq.0 ) then
 155 c
 156         do 21 iaux = 1 , nbfare
 157 c
 158          if ( codret.eq.0 ) then
 159 c
 160           lig = cfaare(cosfli,iaux)
 161           if ( lig.gt.0 ) then
 162 c
 163             do 211 , ligv = 1 , sfnbli
 164               if ( lig.eq.numlig(ligv) ) then
 165                 cfaare(cosfli,iaux) =  ligv
 166                 cfaare(cosfli,cfaare(cosfin,iaux)) = -ligv
 167                 goto 21
 168               endif
 169   211       continue
 170 c
 171             codret = 1
 172 c
 173           endif
 174 c
 175          endif
 176 c
 177    21   continue
 178 c
 179 c====
 180 c 3. boucle sur les familles d'aretes : redonner les numeros d'origine
 181 c====
 182 c
 183       else
 184 c
 185         do 31 , iaux = 1,  nbfare
 186 c
 187           lig = cfaare(cosfli,iaux)
 188           if ( lig.gt.0 ) then
 189             cfaare(cosfli,iaux) =  numlig( lig)
 190           else if (lig.lt.0) then
 191             cfaare(cosfli,iaux) = -numlig(-lig)
 192           endif
 193 c
 194    31   continue
 195 c
 196       endif
 197 c
 198 c====
 199 c 4. la fin
 200 c====
 201 c
 202       if ( codret.ne.0 ) then
 203 c
 204 #include "envex2.h"
 205 c
 206       write (ulsort,texte(langue,7)) lig
 207       write (ulsort,91020) (numlig(ligv),ligv=1,sfnbli)
 208       write (ulsort,texte(langue,1)) 'Sortie', nompro
 209       write (ulsort,texte(langue,2)) codret
 210 c
 211       endif
 212 c
 213 #ifdef _DEBUG_HOMARD_
 214       write (ulsort,texte(langue,1)) 'Sortie', nompro
 215       call dmflsh (iaux)
 216 #endif
 217 c
 218       end