src/tool/Utilitaire/utmcf2.F

   1       subroutine utmcf2 ( nbfrgr,
   2      >                    calfpo, calfta, calfnm,
   3      >                    calgpo, calgta, calgnm,
   4      >                    nbfich,
   5      >                    nomref, lgnofi, poinno,
   6      >                    nomufi, nomstr,
   7      >                    ulsort, langue, codret )
   8 c ______________________________________________________________________
   9 c
  10 c                             H O M A R D
  11 c
  12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  13 c
  14 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  15 c aupres des huissiers de justice Simart et Lavoir a Clamart
  16 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  17 c aupres des huissiers de justice
  18 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  19 c
  20 c    HOMARD est une marque deposee d'Electricite de France
  21 c
  22 c Copyright EDF 1996
  23 c Copyright EDF 1998
  24 c Copyright EDF 2002
  25 c Copyright EDF 2020
  26 c ______________________________________________________________________
  27 c
  28 c     UTilitaire : Mot-Cle - caracterisation des Frontieres - 2
  29 c     --           -   -                         -            -
  30 c ______________________________________________________________________
  31 c .        .     .        .                                            .
  32 c .  nom   . e/s . taille .           description                      .
  33 c .____________________________________________________________________.
  34 c . nbfrgr . e   .    1   . nombre de liens frontieres/groupes         .
  35 c . calfpo .  s  .0:nbfrgr. pointeurs sur le tableau du nom frontieres .
  36 c . calfta .  s  .10nbfrgr. taille du nom des frontieres               .
  37 c . calfnm .  s  .10nbfrgr. nom des frontieres                         .
  38 c . calgpo .  s  .0:nbfrgr. pointeurs sur le tableau du nom groupes    .
  39 c . calgta .  s  .10nbfrgr. taille du nom des groupes                  .
  40 c . calgnm .  s  .10nbfrgr. nom des groupes                            .
  41 c . nbfich . e   .    1   . nombre de fichiers                         .
  42 c . nomref . e   . nbfich . nom de reference des fichiers              .
  43 c . lgnofi . e   . nbfich . longueurs des noms des fichiers            .
  44 c . poinno . e   .0:nbfich. pointeur dans le tableau des noms          .
  45 c . nomufi . e   . lgtanf . noms des fichiers                          .
  46 c . nomstr . e   . nbfich . nom des structures                         .
  47 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  48 c . langue . e   .    1   . langue des messages                        .
  49 c .        .     .        . 1 : francais, 2 : anglais                  .
  50 c . codret . es  .    1   . code de retour des modules                 .
  51 c .        .     .        . 0 : pas de probleme                        .
  52 c .        .     .        . 2 : probleme de lecture                    .
  53 c .        .     .        . 3 : type inconnu                           .
  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 = 'UTMCF2' )
  67 c
  68 #include "nblang.h"
  69 #include "motcle.h"
  70 c
  71       integer nbmcle
  72       parameter ( nbmcle = 1 )
  73 c
  74 c 0.2. ==> communs
  75 c
  76 #include "envex1.h"
  77 c
  78 c 0.3. ==> arguments
  79 c
  80       integer nbfrgr
  81       integer nbfich
  82       integer lgnofi(nbfich), poinno(0:nbfich)
  83       integer calfpo(0:nbfrgr), calfta(10*nbfrgr)
  84       integer calgpo(0:nbfrgr), calgta(10*nbfrgr)
  85 c
  86       character*8 calfnm(10*nbfrgr)
  87       character*8 calgnm(10*nbfrgr)
  88       character*8 nomref(nbfich), nomufi(*), nomstr(nbfich)
  89 c
  90       integer ulsort, langue, codret
  91 c
  92 c 0.4. ==> variables locales
  93 c
  94       integer iaux, jaux, kaux
  95       integer nrfich
  96       integer nrfrgr
  97       integer numero, nrmcle
  98 c
  99       character*8 mclref(0:nbmcle)
 100       character*200 sau200
 101 c
 102       logical mccode(0:nbmcle)
 103 c
 104       integer nbmess
 105       parameter ( nbmess = 10 )
 106       character*80 texte(nblang,nbmess)
 107 c
 108 c 0.5. ==> initialisations
 109 c ______________________________________________________________________
 110 c
 111 c====
 112 c 1. messages
 113 c====
 114 c
 115 c 1.1. ==> tout va bien
 116 c
 117       codret = 0
 118 c
 119 c 1.2. ==> les messages
 120 c
 121 #include "impr01.h"
 122 c
 123 #ifdef _DEBUG_HOMARD_
 124       write (ulsort,texte(langue,1)) 'Entree', nompro
 125       call dmflsh (iaux)
 126 #endif
 127 c
 128       texte(1,4) = '(''Nombre de lien(s) frontiere/groupe :'',i8)'
 129       texte(1,5) =
 130      > '(''Numero du lien en cours de recherche :'',i8)'
 131       texte(1,8) = '(''La valeur de '',a,'' est indecodable.'')'
 132 c
 133       texte(2,4) = '(''Number of link(s) boundary/group:'',i8)'
 134       texte(2,5) = '(''Search for link #'',i8)'
 135       texte(2,8) = '(''The value for '',a,'' cannot be uncoded.'')'
 136 c
 137 c 1.3. ==> preliminaires
 138 c
 139 #ifdef _DEBUG_HOMARD_
 140       write (ulsort,texte(langue,4)) nbfrgr
 141 #endif
 142       mclref( 0) = mcfgfr
 143       mclref( 1) = mcfggr
 144 c
 145 #ifdef _DEBUG_HOMARD_
 146       write(ulsort,*) mclref
 147 #endif
 148 c
 149       calfpo(0) = 0
 150       calgpo(0) = 0
 151 c
 152 c====
 153 c 2. on parcourt toutes les posssibilites de liens
 154 c====
 155 c
 156       do 20 , nrfrgr = 1 , nbfrgr
 157 c
 158 #ifdef _DEBUG_HOMARD_
 159       write (ulsort,texte(langue,5)) nrfrgr
 160 #endif
 161 c
 162 c 2.0. ==> On n'a rien au debut
 163 c
 164         do 201 , iaux = 0 , nbmcle
 165           mccode(iaux) = .false.
 166   201   continue
 167 c
 168         do 200 , nrfich = 1 , nbfich
 169 c
 170 c 2.1. ==> si c'est un des mots-cles possibles, on verifie si c'est
 171 c          pour le bon lien
 172 c
 173           if ( codret.eq.0 ) then
 174 c
 175           nrmcle = -1
 176           do 21 , iaux = 0 , nbmcle
 177             if ( nomref(nrfich).eq.mclref(iaux) ) then
 178               nrmcle = iaux
 179               goto 211
 180             endif
 181    21     continue
 182 c
 183   211     continue
 184 c
 185           if ( nrmcle.ge.0 ) then
 186 c
 187             call utchen ( nomstr(nrfich), numero,
 188      >                    ulsort, langue, codret )
 189 c
 190             if ( nrfrgr.ne.numero ) then
 191               goto 200
 192             endif
 193 c
 194           else
 195 c
 196             goto 200
 197 c
 198           endif
 199 c
 200 c
 201           endif
 202 c
 203 c 2.2. ==> recherche de la valeur
 204 c 2.2.1. ==> Mise sous forme de chaine de la 3eme donnee sur la ligne
 205 c
 206           if ( codret.eq.0 ) then
 207 c
 208           iaux = poinno(nrfich-1) + 1
 209           jaux = lgnofi(nrfich)
 210           call uts8ch ( nomufi(iaux), jaux, sau200,
 211      >                  ulsort, langue, codret )
 212 c
 213 #ifdef _DEBUG_HOMARD_
 214       write (ulsort,*) sau200
 215 #endif
 216           endif
 217 c
 218 c 2.2.2. ==> Conversions
 219 c
 220           if ( codret.eq.0 ) then
 221 #ifdef _DEBUG_HOMARD_
 222       write (ulsort,*) 'nrmcle =', nrmcle
 223 #endif
 224 c
 225 c 2.2.2.1. ==> Stockage du nom de la frontiere
 226 c
 227           if ( nrmcle.eq.0 ) then
 228 #ifdef _DEBUG_HOMARD_
 229       write (ulsort,*) 'Stockage du nom de la frontiere'
 230 #endif
 231 c
 232             iaux = mod(lgnofi(nrfich),8)
 233             kaux = (lgnofi(nrfich) - iaux)/8
 234             if ( iaux.ne.0 ) then
 235               kaux = kaux + 1
 236             endif
 237             calfpo(nrfrgr) = calfpo(nrfrgr-1) + kaux
 238             jaux = 1
 239             do 2221 , iaux = 1 , kaux
 240               calfta(calfpo(nrfrgr-1)+iaux) = 8
 241               calfnm(calfpo(nrfrgr-1)+iaux) = sau200(jaux:jaux+7)
 242               jaux = jaux + 8
 243  2221       continue
 244             iaux = mod(lgnofi(nrfich),8)
 245             if ( iaux.ne.0 ) then
 246               calfta(calfpo(nrfrgr)) = iaux
 247             endif
 248 c
 249 c 2.2.2.2. ==> Stockage du nom du groupe
 250 c
 251           else
 252 #ifdef _DEBUG_HOMARD_
 253       write (ulsort,*) 'Stockage du nom du groupe'
 254 #endif
 255 c
 256             iaux = mod(lgnofi(nrfich),8)
 257             kaux = (lgnofi(nrfich) - iaux)/8
 258             if ( iaux.ne.0 ) then
 259               kaux = kaux + 1
 260             endif
 261             calgpo(nrfrgr) = calgpo(nrfrgr-1) + kaux
 262             jaux = 1
 263             do 2222 , iaux = 1 , kaux
 264               calgta(calgpo(nrfrgr-1)+iaux) = 8
 265               calgnm(calgpo(nrfrgr-1)+iaux) = sau200(jaux:jaux+7)
 266               jaux = jaux + 8
 267  2222       continue
 268             iaux = mod(lgnofi(nrfich),8)
 269             if ( iaux.ne.0 ) then
 270               calgta(calgpo(nrfrgr)) = iaux
 271             endif
 272 c
 273           endif
 274 c
 275           endif
 276 c
 277 c 2.2.3. ==> Archivage
 278 c
 279           if ( codret.eq.0 ) then
 280 c
 281           mccode(nrmcle) = .true.
 282 c
 283           endif
 284 c
 285 c 2.3. ==> si on a tout trouve, on passe a la frontiere suivante,
 286 c          apres controle
 287 c
 288           if ( codret.eq.0 ) then
 289 c
 290           if ( mccode(0) .and. mccode(1) ) then
 291 c
 292             goto 20
 293 c
 294           endif
 295 c
 296           endif
 297 c
 298 c
 299   200   continue
 300 c
 301 c 2.4. ==> si on arrive ici, c'est qu'il en manque pour la
 302 c          frontiere courante
 303 c
 304         if ( codret.eq.0 ) then
 305 c
 306         write (ulsort,texte(langue,5)) nrfrgr
 307         do 24 , iaux = 0 , nbmcle
 308           if ( .not.mccode(iaux) ) then
 309             write (ulsort,texte(langue,8)) mclref(iaux)
 310           endif
 311    24   continue
 312 c
 313         codret = 2
 314 c
 315         endif
 316 c
 317    20 continue
 318 c
 319 c====
 320 c 3. la fin
 321 c====
 322 c
 323       if ( codret.ne.0 ) then
 324 c
 325       call dmflsh(iaux)
 326 c
 327 #include "envex2.h"
 328 c
 329       write (ulsort,texte(langue,1)) 'Sortie', nompro
 330       write (ulsort,texte(langue,2)) codret
 331 c
 332       endif
 333 c
 334 #ifdef _DEBUG_HOMARD_
 335       write (ulsort,texte(langue,1)) 'Sortie', nompro
 336       call dmflsh (iaux)
 337 #endif
 338 c
 339       end