src/tool/Suivi_Frontiere/sfgrfb.F

   1       subroutine sfgrfb ( nocmaf, ncafdg,
   2      >                    nblign, nbf, nbgrmx,
   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 - GRoupes de la Frontiere - phase B
  25 c   -        -           --            -                 -
  26 c remarque : sfgrfa et sfgrfb sont des clones
  27 c ______________________________________________________________________
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . nocmaf . e   . char*8 . nom de l'objet maillage de la frontiere    .
  31 c . ncafdg . es  . char*8 . nom de l'objet groupes/attributs frontiere .
  32 c . nblign .   s .    1   . nombre de lignes a considerer              .
  33 c . nbf    . e   .   1    . nombre de familles du maillage frontiere   .
  34 c . nbgrmx . e   .   1    . nombre maxi de groupes dans les familles   .
  35 c . langue . e   .    1   . langue des messages                        .
  36 c .        .     .        . 1 : francais, 2 : anglais                  .
  37 c . codret . es  .    1   . code de retour des modules                 .
  38 c .        .     .        . 0 : pas de probleme                        .
  39 c .        .     .        . 2 : probleme avec la memoire               .
  40 c .        .     .        . 3 : probleme avec le fichier               .
  41 c .        .     .        . 5 : contenu incorrect                      .
  42 c ______________________________________________________________________
  43 c
  44 c====
  45 c 0. declarations et dimensionnement
  46 c====
  47 c
  48 c 0.1. ==> generalites
  49 c
  50       implicit none
  51       save
  52 c
  53       character*6 nompro
  54       parameter ( nompro = 'SFGRFB' )
  55 c
  56 #include "nblang.h"
  57 c
  58 c 0.2. ==> communs
  59 c
  60 #include "envex1.h"
  61 c
  62 #include "gmenti.h"
  63 #include "gmstri.h"
  64 c
  65 c 0.3. ==> arguments
  66 c
  67       integer nblign, nbf, nbgrmx
  68 c
  69       character*8 nocmaf, ncafdg
  70 c
  71       integer ulsort, langue, codret
  72 c
  73 c 0.4. ==> variables locales
  74 c
  75       integer iaux, jaux
  76       integer lgtabl
  77       integer adtyel, adfael
  78       integer pointl, pttgrl, ptngrl
  79       integer adgrtb, adgrpo, adnufa
  80       integer nbmail, nbfseg
  81       integer ptrav1, ptrav2
  82       integer codre1, codre2
  83       integer codre0
  84 c
  85       character*8 ntrav1, ntrav2
  86 c
  87       integer nbmess
  88       parameter ( nbmess = 10 )
  89       character*80 texte(nblang,nbmess)
  90 c
  91 c 0.5. ==> initialisations
  92 c ______________________________________________________________________
  93 c
  94 c====
  95 c 1. messages
  96 c====
  97 c
  98 #include "impr01.h"
  99 c
 100 #ifdef _DEBUG_HOMARD_
 101       write (ulsort,texte(langue,1)) 'Entree', nompro
 102       call dmflsh (iaux)
 103 #endif
 104 c
 105 #include "impr03.h"
 106 c
 107       codret = 0
 108 c
 109 c====
 110 c 2. recuperation des adresses
 111 c====
 112 #ifdef _DEBUG_HOMARD_
 113       write (ulsort,90002) '2. adresses et reperage ; codret', codret
 114 #endif
 115 c
 116 c 2.1. ==> le tableau trav1 contiendra la liste des familles du maillage
 117 c          frontiere qui contiennent au moins un groupe. Il est alloue
 118 c          au maximum theorique qui vaut le nombre total de groupes
 119 c          constituant les familles + 1 pour la famille nulle
 120 c          le tableau trav2 contiendra la liste des numeros des groupes
 121 c          voulus et qui sont effectivement un groupe frontiere
 122 c
 123       if ( codret.eq.0 ) then
 124 c
 125       iaux = nbgrmx + 1
 126       call gmalot ( ntrav1, 'entier  ',   iaux, ptrav1, codre1 )
 127       call gmalot ( ntrav2, 'entier  ', nblign, ptrav2, codre2)
 128 c
 129       codre0 = min ( codre1, codre2 )
 130       codret = max ( abs(codre0), codret,
 131      >               codre1, codre2 )
 132 c
 133       endif
 134 c
 135 c 2.2. ==> adresses et filtrage
 136 c
 137       if ( codret.eq.0 ) then
 138 c
 139 #ifdef _DEBUG_HOMARD_
 140       call gmprsx (nompro,nocmaf )
 141 #endif
 142 c
 143 #ifdef _DEBUG_HOMARD_
 144       write (ulsort,texte(langue,3)) 'SFGRF0', nompro
 145 #endif
 146       call sfgrf0 ( nocmaf,
 147      >              nbmail,
 148      >              adtyel, adfael,
 149      >              adnufa, adgrpo, adgrtb,
 150      >              nbfseg, imem(ptrav1),
 151      >              ulsort, langue, codret)
 152 c
 153 #ifdef _DEBUG_HOMARD_
 154       call gmprsx (nompro,ntrav1 )
 155       call gmprsx (nompro,ntrav2 )
 156 #endif
 157 c
 158       endif
 159 c
 160 c====
 161 c 3. recuperation des caracteristiques de la liste
 162 c====
 163 #ifdef _DEBUG_HOMARD_
 164       write (ulsort,90002) '3. recuperation ; codret', codret
 165 #endif
 166 c
 167       if ( codret.eq.0 ) then
 168 c
 169 #ifdef _DEBUG_HOMARD_
 170       call gmprsx (nompro,ncafdg )
 171       call gmprsx (nompro,ncafdg//'.Pointeur' )
 172       call gmprsx (nompro,ncafdg//'.Table' )
 173       call gmprsx (nompro,ncafdg//'.Taille' )
 174 #endif
 175       iaux = 6
 176 #ifdef _DEBUG_HOMARD_
 177       write (ulsort,texte(langue,3)) 'UTADPT', nompro
 178 #endif
 179       call utadpt ( ncafdg, iaux,
 180      >              jaux, lgtabl,
 181      >              pointl, pttgrl, ptngrl,
 182      >              ulsort, langue, codret )
 183 c
 184       endif
 185 c
 186 c====
 187 c 4. on verifie les tableaux
 188 c====
 189 #ifdef _DEBUG_HOMARD_
 190       write (ulsort,90002) '4. remplissage ; codret', codret
 191 #endif
 192 c
 193       if ( codret.eq.0 ) then
 194 c
 195 cgn      call gmprsx (nompro, ncfami//'.Groupe.Pointeur' )
 196 cgn      call gmprsx (nompro, ncfami//'.Groupe.Table' )
 197 cgn      call gmprsx (nompro, ncfami//'.Numero' )
 198 #ifdef _DEBUG_HOMARD_
 199       write (ulsort,texte(langue,3)) 'SFGRF3', nompro
 200 #endif
 201       call sfgrf3 ( nbfseg,
 202      >              nbf, nbgrmx, nblign, lgtabl,
 203      >              imem(pointl), imem(pttgrl), smem(ptngrl),
 204      >              imem(adgrpo), smem(adgrtb), imem(adnufa),
 205      >              imem(ptrav1), imem(ptrav2), ncafdg,
 206      >              ulsort, langue, codret )
 207 c
 208 #ifdef _DEBUG_HOMARD_
 209       call gmprsx (nompro,ncafdg )
 210       call gmprsx (nompro,ncafdg//'.Pointeur' )
 211       call gmprsx (nompro,ncafdg//'.Table' )
 212       call gmprsx (nompro,ncafdg//'.Taille' )
 213 #endif
 214 c
 215       endif
 216 c
 217 c====
 218 c 5. menage
 219 c====
 220 c
 221       if ( codret.eq.0 ) then
 222 c
 223       call gmlboj ( ntrav1 , codre1 )
 224       call gmlboj ( ntrav2 , codre2 )
 225 c
 226       codre0 = min ( codre1, codre2 )
 227       codret = max ( abs(codre0), codret,
 228      >               codre1, codre2 )
 229 c
 230       endif
 231 c
 232 c====
 233 c 6. la fin
 234 c====
 235 c
 236       if ( codret.ne.0 ) then
 237 c
 238 #include "envex2.h"
 239 c
 240       write (ulsort,texte(langue,1)) 'Sortie', nompro
 241       write (ulsort,texte(langue,2)) codret
 242 c
 243       endif
 244 c
 245 #ifdef _DEBUG_HOMARD_
 246       write (ulsort,texte(langue,1)) 'Sortie', nompro
 247       call dmflsh (iaux)
 248 #endif
 249 c
 250       end