src/tool/AV_Conversion/vcfia2.F

   1       subroutine vcfia2 ( ngrofi, grfipt, grfitb,
   2      >                    nbfmed, numfam, grfmpo, grfmtb,
   3      >                    nbfamd,
   4      >                    tbxgro, tbxfam,
   5      >                    ulsort, langue, codret )
   6 c ______________________________________________________________________
   7 c
   8 c                             H O M A R D
   9 c
  10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  11 c
  12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  13 c aupres des huissiers de justice Simart et Lavoir a Clamart
  14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  15 c aupres des huissiers de justice
  16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  17 c
  18 c    HOMARD est une marque deposee d'Electricite de France
  19 c
  20 c Copyright EDF 1996
  21 c Copyright EDF 1998
  22 c Copyright EDF 2002
  23 c Copyright EDF 2020
  24 c ______________________________________________________________________
  25 c
  26 c    aVant adaptation - FIltrage de l'Adaptation - phase 2
  27 c     -                 --            -                  -
  28 c
  29 c    Retourne les numeros des familles MED correspondant
  30 c    aux groupes demandes
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . ngrofi . e   .    1   . nombre de groupes de filtrage              .
  36 c . grfipt . e   .0:ngrofi. groupes de filtrage - pointeur             .
  37 c . grfitb . e   .   *    . groupes de filtrage - table                .
  38 c . nbfmed . e   .    1   . nombre de familles MED dans le maillage    .
  39 c . numfam . e   . nbfmed . numero MED des familles                    .
  40 c . grfmpo . e   .0:nbfmed. groupes calcul - pointeur                  .
  41 c . grfmtb . e   .   *    . groupes calcul - table                     .
  42 c . nbfamd .   s .   1    . nombre de familles MED concernees          .
  43 c . tbxgro . -   . ngrofi . tableau de travail                         .
  44 c . tbxfam . s   . nbfmed . tableau de travail                         .
  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 .        .     .        . sinon 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 = 'VCFIA2' )
  64 c
  65 #include "nblang.h"
  66 c
  67 c 0.2. ==> communs
  68 c
  69 #include "envex1.h"
  70 c
  71 c 0.3. ==> arguments
  72 c
  73       integer ngrofi, grfipt(0:ngrofi)
  74       integer nbfmed, numfam(nbfmed), grfmpo(0:nbfmed)
  75       integer nbfamd
  76       integer tbxgro(ngrofi), tbxfam(nbfmed)
  77 c
  78       character*8 grfitb(*)
  79       character*8 grfmtb(*)
  80 c
  81       integer ulsort, langue, codret
  82 c
  83 c 0.4. ==> variables locales
  84 c
  85       integer iaux, jaux
  86       integer fam, nbgr, gr
  87       integer lgngrf, lggrfi
  88       integer nugrfi
  89 c
  90       character*80 groupf
  91       character*200 sau200
  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. messages
 102 c====
 103 c
 104 #include "impr01.h"
 105 c
 106 #ifdef _DEBUG_HOMARD_
 107       write (ulsort,texte(langue,1)) 'Entree', nompro
 108       call dmflsh (iaux)
 109 #endif
 110 c
 111       texte(1,4) = '(/,''Famille MED numero'',i10)'
 112       texte(1,5) = '(''. Groupe'',i5,'' : '',a)'
 113       texte(1,6) = '(a,''Groupe de filtrage : '',a)'
 114       texte(1,7) =
 115      >'(5x,''Attention : ce groupe est inconnu dans le maillage.'')'
 116       texte(1,8) = '(''Nombre de familles MED concernees :'',i10)'
 117       texte(1,9) = '(''Numero de ces familles :'')'
 118       texte(1,10) = '(''... Le groupe a ete trouve dans la famille.'')'
 119 c
 120       texte(2,4) = '(/,''MED family #'',i10)'
 121       texte(2,5) = '(''. Group'',i5,'': '',a)'
 122       texte(2,6) = '(a,''Filtering group: '',a)'
 123       texte(2,7) =
 124      >'(5x,''Warning : this group is not known in the mesh.'')'
 125       texte(2,8) = '(''Number of MED families in cause:'',i10)'
 126       texte(2,9) = '(''# of those families:'')'
 127       texte(2,10) = '(''... The group was found into the family.'')'
 128 c
 129 #include "impr03.h"
 130 c
 131       codret = 0
 132 c
 133 c====
 134 c 2. a priori, aucun groupe n'a ete repere
 135 c====
 136 c
 137       do 21 , nugrfi = 1 , ngrofi
 138         tbxgro(nugrfi) = 0
 139    21 continue
 140 c
 141 c====
 142 c 3. Recherche des familles MED concernees
 143 c    Remarque : le decodage est analogue a celui de vcsffl
 144 c====
 145 c
 146       if ( codret.eq.0 ) then
 147 c
 148       nbfamd = 0
 149 c
 150 c 3.1. ==> on parcourt toutes les familles MED du maillage
 151 c
 152       do 31 , fam = 1 , nbfmed
 153 c
 154 #ifdef _DEBUG_HOMARD_
 155         write (ulsort,texte(langue,4)) fam
 156 #endif
 157 c
 158         nbgr = (grfmpo(fam)-grfmpo(fam-1))/10
 159 c
 160 c 3.1.1. ==> on parcourt tous les groupes entrant dans la
 161 c            definition de la famille
 162 c
 163         do 311 , gr = 1, nbgr
 164 c
 165 c 3.1.1.1. ==> nom du groupe associe
 166 c             adresse du debut du groupe numero gr de la famille fam
 167           iaux = grfmpo(fam-1)+1+10*(gr-1)
 168 c
 169           if ( codret.eq.0 ) then
 170 c
 171 c         recuperation du nom du groupe numero gr dans la famille
 172 c         numero fam
 173           call uts8ch ( grfmtb(iaux), 80, groupf,
 174      >                  ulsort, langue, codret )
 175 c
 176           endif
 177 c
 178           if ( codret.eq.0 ) then
 179 c
 180 c         longueur utile du nom du groupe
 181           call utlgut ( lgngrf, groupf, ulsort, langue, codret )
 182 c
 183 #ifdef _DEBUG_HOMARD_
 184           write (ulsort,texte(langue,5)) gr, groupf(1:lgngrf)
 185 #endif
 186           endif
 187 c
 188 c 3.1.1.2. ==> on parcourt tous les groupes designes pour le filtrage
 189 c
 190           if ( codret.eq.0 ) then
 191 c
 192           do 3112 , nugrfi = 1 , ngrofi
 193 c
 194 c 3.1.1.2.1. ==> nom du groupe associe
 195 c
 196             if ( codret.eq.0 ) then
 197 c
 198             jaux = grfipt(nugrfi-1) + 1
 199             call uts8ch ( grfitb(jaux), 200, sau200,
 200      >                    ulsort, langue, codret )
 201 c
 202             endif
 203 c
 204             if ( codret.eq.0 ) then
 205 c
 206             call utlgut ( lggrfi, sau200, ulsort, langue, codret )
 207 c
 208 #ifdef _DEBUG_HOMARD_
 209             write (ulsort,texte(langue,6)) '.. ', sau200(1:lggrfi)
 210 #endif
 211 c
 212             endif
 213 c
 214 c 3.1.1.2.2. ==> est-ce le meme ?
 215 c                si oui on memorise le numero de cette famille MED
 216 c
 217             if ( codret.eq.0 ) then
 218 c
 219             if ( lgngrf.eq.lggrfi ) then
 220 c
 221               if ( groupf(1:lgngrf).eq.sau200(1:lggrfi) ) then
 222 #ifdef _DEBUG_HOMARD_
 223                 write (ulsort,texte(langue,10))
 224 #endif
 225                 tbxgro(nugrfi) = tbxgro(nugrfi) + 1
 226                 do 3113 , jaux = 1 , nbfamd
 227                   if ( tbxfam(jaux).eq.numfam(fam) ) then
 228                     goto 3112
 229                   endif
 230  3113           continue
 231                 nbfamd = nbfamd + 1
 232                 tbxfam(nbfamd) = numfam(fam)
 233               endif
 234 c
 235             endif
 236 c
 237             endif
 238 c
 239  3112     continue
 240 c
 241           endif
 242 c
 243   311   continue
 244 c
 245    31 continue
 246 c
 247 #ifdef _DEBUG_HOMARD_
 248       write (ulsort,texte(langue,8)) nbfamd
 249       write (ulsort,texte(langue,9))
 250       write (ulsort,91020) (tbxfam(iaux), iaux=1,nbfamd)
 251 #endif
 252 c
 253       endif
 254 c
 255 c====
 256 c 4. Information
 257 c====
 258 c
 259       do 41 , nugrfi = 1 , ngrofi
 260 c
 261         if ( codret.eq.0 ) then
 262 c
 263         jaux = grfipt(nugrfi-1) + 1
 264 c
 265 #ifdef _DEBUG_HOMARD_
 266         write (ulsort,texte(langue,5)) nugrfi, grfitb(jaux)//' ...'
 267 #endif
 268 c
 269         call uts8ch ( grfitb(jaux), 200, sau200,
 270      >                ulsort, langue, codret )
 271 c
 272         endif
 273 c
 274         if ( codret.eq.0 ) then
 275 c
 276         call utlgut ( lggrfi, sau200, ulsort, langue, codret )
 277 c
 278         endif
 279 c
 280         if ( codret.eq.0 ) then
 281 c
 282         write (ulsort,texte(langue,6)) ' ', sau200(1:lggrfi)
 283         if ( tbxgro(nugrfi).eq.0 ) then
 284           write (ulsort,texte(langue,7))
 285         endif
 286 c
 287         endif
 288 c
 289    41 continue
 290 c
 291 c====
 292 c 4. la fin
 293 c====
 294 c
 295       if ( codret.ne.0 ) then
 296 c
 297 #include "envex2.h"
 298 c
 299       write (ulsort,texte(langue,1)) 'Sortie', nompro
 300       write (ulsort,texte(langue,2)) codret
 301 c
 302       endif
 303 c
 304 #ifdef _DEBUG_HOMARD_
 305       write (ulsort,texte(langue,1)) 'Sortie', nompro
 306       call dmflsh (iaux)
 307 #endif
 308 c
 309       end