src/tool/HOMARD_00/hosufr.F

   1       subroutine hosufr ( codret )
   2 c ______________________________________________________________________
   3 c
   4 c                             H O M A R D
   5 c
   6 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   7 c
   8 c Version originale enregistree le 18 juin 1996 sous le numero 96036
   9 c aupres des huissiers de justice Simart et Lavoir a Clamart
  10 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  11 c aupres des huissiers de justice
  12 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  13 c
  14 c    HOMARD est une marque deposee d'Electricite de France
  15 c
  16 c Copyright EDF 1996
  17 c Copyright EDF 1998
  18 c Copyright EDF 2002
  19 c Copyright EDF 2020
  20 c ______________________________________________________________________
  21 c
  22 c   HOMARD : SUivi de FRontiere
  23 c   --       --       --
  24 c
  25 c remarque : on n'execute ce programme que si le precedent s'est
  26 c            bien passe
  27 c
  28 c ______________________________________________________________________
  29 c .        .     .        .                                            .
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . codret . es  .    1   . code de retour des modules                 .
  33 c .        .     .        . en entree = celui du module d'avant        .
  34 c .        .     .        . en sortie = celui du module en cours       .
  35 c .        .     .        . 0 : pas de probleme                        .
  36 c .        .     .        . 1 : manque de temps cpu                    .
  37 c .        .     .        . 2x : probleme dans les memoires            .
  38 c .        .     .        . 3x : probleme dans les fichiers            .
  39 c .        .     .        . 5 : mauvaises options                      .
  40 c .        .     .        . 6 : problemes dans les noms d'objet        .
  41 c ______________________________________________________________________
  42 c
  43 c====
  44 c 0. declarations et dimensionnement
  45 c====
  46 c
  47 c 0.1. ==> generalites
  48 c
  49       implicit none
  50       save
  51 c
  52       character*6 nompro
  53       parameter ( nompro = 'HOSUFR' )
  54 c
  55 #include "motcle.h"
  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 #include "cndoad.h"
  66 c
  67 c 0.3. ==> arguments
  68 c
  69       integer codret
  70 c
  71 c 0.4. ==> variables locales
  72 c
  73       integer ulsort, langue, codava
  74       integer adopti, lgopti
  75       integer adopts, lgopts
  76       integer adetco, lgetco
  77       integer nrsect, nrssse
  78       integer nretap, nrsset
  79       integer iaux
  80       integer nbarfr, nbqufr
  81 c
  82       character*6 saux
  83       character*8 typobs, nohmap
  84 c
  85       integer nbmess
  86       parameter ( nbmess = 10 )
  87       character*80 texte(nblang,nbmess)
  88 c
  89 c 0.5. ==> initialisations
  90 c ______________________________________________________________________
  91 c
  92 c====
  93 c 1. les initialisations
  94 c====
  95 c
  96       codava = codret
  97 c
  98 c=======================================================================
  99       if ( codava.eq.0 ) then
 100 c=======================================================================
 101 c
 102 #ifdef _DEBUG_HOMARD_
 103       call gmprsx (nompro, nndoad )
 104       call gmprsx (nompro, nndoad//'.OptEnt' )
 105       call gmprsx (nompro, nndoad//'.OptRee' )
 106       call gmprsx (nompro, nndoad//'.OptCar' )
 107       call gmprsx (nompro, nndoad//'.EtatCour' )
 108 #endif
 109 c
 110 c 1.2. ==> le numero d'unite logique de la liste standard
 111 c
 112       call utulls ( ulsort, codret )
 113 c
 114 c 1.3. ==> la langue des messages
 115 c
 116       call gmadoj ( nndoad//'.OptEnt', adopti, lgopti, codret )
 117       if ( codret.eq.0 ) then
 118         langue = imem(adopti)
 119       else
 120         langue = 1
 121         codret = 2
 122       endif
 123 c
 124 #include "impr01.h"
 125 c
 126 #ifdef _DEBUG_HOMARD_
 127       write (ulsort,texte(langue,1)) 'Entree', nompro
 128       call dmflsh (iaux)
 129 #endif
 130 c
 131 c 1.4. ==> l'etat courant
 132 c
 133       call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret )
 134 c
 135       if ( codret.eq.0 ) then
 136         if ( mod(imem(adopti+28),2).eq.0 .or.
 137      >       mod(imem(adopti+28),3).eq.0 .or.
 138      >       mod(imem(adopti+28),5).eq.0 ) then
 139           nretap = imem(adetco) + 1
 140           imem(adetco) = nretap
 141           nrsset = -1
 142           imem(adetco+1) = nrsset
 143         endif
 144         nrsect = imem(adetco+2) + 10
 145         imem(adetco+2) = nrsect
 146         nrssse = nrsect
 147         imem(adetco+3) = nrssse
 148       else
 149         nretap = -1
 150         nrsset = -1
 151         nrsect = 200
 152         nrssse = nrsect
 153         codret = 2
 154       endif
 155 c
 156 c-----------------------------------------------------------------------
 157       if ( mod(imem(adopti+28),2).eq.0 .or.
 158      >     mod(imem(adopti+28),3).eq.0 .or.
 159      >     mod(imem(adopti+28),5).eq.0 ) then
 160 c-----------------------------------------------------------------------
 161 c
 162 c 1.5. ==> le debut des mesures de temps
 163 c
 164       call gtdems (nrsect)
 165 c
 166 c 1.6. ==> les messages
 167 c
 168       texte(1,4) = '(//,a6,'' S U I V I   D E   F R O N T I E R E'')'
 169       texte(1,5) = '(42(''=''),/)'
 170 c
 171       texte(2,4) = '(//,a6,'' B O U N D A R Y   F O L L O W I N G'')'
 172       texte(2,5) = '(42(''=''),/)'
 173 c
 174 c 1.7. ==> le titre
 175 c
 176       call utcvne ( nretap, nrsset, saux, iaux, codret )
 177 c
 178       write (ulsort,texte(langue,4)) saux
 179       write (ulsort,texte(langue,5))
 180 c
 181       nrsset = 0
 182       imem(adetco+1) = nrsset
 183 c
 184 c 1.8. ==> les noms d'objets a conserver
 185 c
 186       if ( codret.eq.0 ) then
 187         call gmadoj ( nndoad//'.OptCar', adopts, lgopts, codret )
 188         if ( codret.ne.0 ) then
 189           codret = 2
 190         endif
 191       endif
 192 c
 193 c 1.9. ==> le maillage homard
 194 c
 195       if ( codret.eq.0 ) then
 196 c
 197       typobs = mchmap
 198       iaux = 0
 199       call utosno ( typobs, nohmap, iaux, ulsort, langue, codret )
 200 c
 201       endif
 202 c
 203 #include "impr03.h"
 204 c
 205 c====
 206 c 2. A-t-on des aretes et des quadrangles concernees
 207 c    par le suivi de frontiere ?
 208 c====
 209 #ifdef _DEBUG_HOMARD_
 210       write (ulsort,90002) '2. Tests des aretes ; codret', codret
 211 #endif
 212 c
 213       if ( codret.eq.0 ) then
 214 c
 215       nbarfr = 0
 216       nbqufr = 0
 217       iaux = 1
 218 c
 219 #ifdef _DEBUG_HOMARD_
 220       write (ulsort,texte(langue,3)) 'SFCOAQ', nompro
 221 #endif
 222       call sfcoaq ( nohmap, iaux, nbarfr, nbqufr,
 223      >              ulsort, langue, codret )
 224 c
 225       endif
 226 c
 227 c
 228 c====
 229 c 3. Traitement
 230 c====
 231 #ifdef _DEBUG_HOMARD_
 232       write (ulsort,90002) '3. Traitement ; codret', codret
 233       write (ulsort,90002) 'nbarfr', nbarfr
 234       write (ulsort,90002) 'nbqufr', nbqufr
 235 #endif
 236 c
 237       if ( nbarfr.gt.0 ) then
 238 c
 239         if ( codret.eq.0 ) then
 240 c
 241         imem(adetco+3) = imem(adetco+3) + 1
 242         nrssse = imem(adetco+3)
 243 c
 244 #ifdef _DEBUG_HOMARD_
 245       write (ulsort,texte(langue,3)) 'SFCAFR', nompro
 246 #endif
 247         call sfcafr ( lgopti, imem(adopti),
 248      >                lgopts, smem(adopts),
 249      >                lgetco, imem(adetco),
 250      >                nohmap, nbarfr, nbqufr,
 251      >                ulsort, langue, codret )
 252 c
 253         endif
 254 c
 255       endif
 256 c
 257 c====
 258 c 4. la fin
 259 c====
 260 c
 261 c 4.1. ==> message si erreur
 262 c
 263       if ( codret.ne.0 ) then
 264 c
 265 #include "envex2.h"
 266 c
 267       write (ulsort,texte(langue,1)) 'Sortie', nompro
 268       write (ulsort,texte(langue,2)) codret
 269 c
 270       endif
 271 c
 272 c 4.3. ==> fin des mesures de temps de la section
 273 c
 274       call gtfims (nrsect)
 275 c
 276 c-----------------------------------------------------------------------
 277       endif
 278 c-----------------------------------------------------------------------
 279 c
 280 #ifdef _DEBUG_HOMARD_
 281       write (ulsort,texte(langue,1)) 'Sortie', nompro
 282       call dmflsh (iaux)
 283 #endif
 284 c
 285 c=======================================================================
 286       endif
 287 c=======================================================================
 288 c
 289       end