src/tool/Decision/delist.F

   1       subroutine delist ( nomail, nmprde, avappr,
   2      >                    lgopts, taopts,
   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 traitement des DEcisions - LISTe des decisions
  25 c                --          ----
  26 c     Remarque : Les appels ont lieu seulement en mode DEBUG
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . nomail . e   .  ch8   . nom de l'objet contenant le maillage       .
  32 c . nmprde . e   .  ch8   . nom du programme a pister                  .
  33 c . avappr . e   .   1    . 1 : impression avant l'appel a "nmprde"    .
  34 c .        .     .        . 2 : impression apres l'appel a "nmprde"    .
  35 c . lgopts . e   .   1    . longueur du tableau des options caracteres .
  36 c . taopts . e   . lgoptc . tableau des options caracteres             .
  37 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  38 c . langue . e   .    1   . langue des messages                        .
  39 c .        .     .        . 1 : francais, 2 : anglais                  .
  40 c . codret . es  .    1   . code de retour des modules                 .
  41 c .        .     .        . 0 : pas de probleme                        .
  42 c .        .     .        . sinon, probleme                            .
  43 c ______________________________________________________________________
  44 c
  45 c====
  46 c 0. declarations et dimensionnement
  47 c====
  48 c
  49 c 0.1. ==> generalites
  50 c
  51       implicit none
  52       save
  53 c
  54       character*6 nompro
  55       parameter ( nompro = 'DELIST' )
  56 c
  57 #include "nblang.h"
  58 c
  59 c 0.2. ==> communs
  60 c
  61 #include "envex1.h"
  62 c
  63 #include "gmenti.h"
  64 c
  65 #include "envca1.h"
  66 #include "nombtr.h"
  67 #include "nombqu.h"
  68 #include "nombhe.h"
  69 c
  70 c 0.3. ==> arguments
  71 c
  72       character*8 nomail
  73 c
  74       character*6 nmprde
  75 c
  76       integer avappr
  77 c
  78       integer lgopts
  79       character*8 taopts(lgopts)
  80 c
  81       integer ulsort, langue, codret
  82 c
  83 c 0.4. ==> variables locales
  84 c
  85       integer iaux, jaux
  86 c
  87       integer pdecfa, pdecar
  88       integer phetar, pmerar
  89       integer phettr, paretr, pnivtr
  90       integer phetqu, parequ, pnivqu
  91       integer phethe, pquahe
  92       integer pposif, pfacar
  93       integer adhoar, adhotr, adhoqu
  94 c
  95       integer codre0, codre1, codre2
  96 c
  97       character*8 ntrav1, ntrav2
  98       character*8 norenu
  99       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 100       character*8 nhtetr, nhhexa, nhpyra, nhpent
 101       character*8 nhelig
 102       character*8 nhvois, nhsupe, nhsups
 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 #include "impr01.h"
 116 c
 117 #ifdef _DEBUG_HOMARD_
 118       write (ulsort,texte(langue,1)) 'Entree', nompro
 119       call dmflsh (iaux)
 120 #endif
 121 c
 122       texte(1,4) = '(/,''Avant appel a '',a6,'' :'',/)'
 123       texte(1,5) = '(/,''Apres appel a '',a6,'' :'',/)'
 124       texte(1,10) = '(/,''Mauvais code pour '',a6,'' : '',i8,/)'
 125 c
 126       texte(2,4) = '(/,''Before calling '',a6,'':'',/)'
 127       texte(2,5) = '(/,''After calling '',a6,'':'',/)'
 128       texte(2,10) = '(/,''Bad code for '',a6,'': '',i8,/)'
 129 c
 130 #include "impr03.h"
 131 c
 132 c====
 133 c 2. recuperation des pointeurs, initialisations
 134 c====
 135 c
 136 c 2.1. ==> structure generale
 137 c
 138       if ( codret.eq.0 ) then
 139 c
 140       call utnomh ( nomail,
 141      >                sdim,   mdim,
 142      >               degre, maconf, homolo, hierar,
 143      >              rafdef, nbmane, typcca, typsfr, maextr,
 144      >              mailet,
 145      >              norenu,
 146      >              nhnoeu, nhmapo, nharet,
 147      >              nhtria, nhquad,
 148      >              nhtetr, nhhexa, nhpyra, nhpent,
 149      >              nhelig,
 150      >              nhvois, nhsupe, nhsups,
 151      >              ulsort, langue, codret)
 152 c
 153       endif
 154 c
 155 c 2.2. ==> tableaux
 156 c
 157       if ( codret.eq.0 ) then
 158 c
 159       iaux = 10
 160       if ( homolo.ge.2 ) then
 161         iaux = iaux*29
 162       endif
 163 #ifdef _DEBUG_HOMARD_
 164       write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
 165 #endif
 166       call utad02 ( iaux, nharet,
 167      >              phetar, jaux  , jaux  , pmerar,
 168      >                jaux,   jaux,   jaux,
 169      >                jaux,   jaux,   jaux,
 170      >                jaux, adhoar,   jaux,
 171      >              ulsort, langue, codret )
 172 c
 173       if ( nbtrto.ne.0 ) then
 174 c
 175         iaux = 22
 176         if ( homolo.ge.3 ) then
 177           iaux = iaux*29
 178         endif
 179 #ifdef _DEBUG_HOMARD_
 180       write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
 181 #endif
 182         call utad02 ( iaux, nhtria,
 183      >                phettr, paretr, jaux  ,  jaux,
 184      >                  jaux,   jaux,   jaux,
 185      >                pnivtr,   jaux,   jaux,
 186      >                  jaux, adhotr,   jaux,
 187      >                ulsort, langue, codret )
 188 c
 189       endif
 190 c
 191       if ( nbquto.ne.0 ) then
 192 c
 193         iaux = 22
 194         if ( homolo.ge.3 ) then
 195           iaux = iaux*29
 196         endif
 197 #ifdef _DEBUG_HOMARD_
 198       write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
 199 #endif
 200         call utad02 ( iaux, nhquad,
 201      >                phetqu, parequ, jaux  , jaux,
 202      >                  jaux,   jaux,   jaux,
 203      >                pnivqu,   jaux,   jaux,
 204      >                  jaux, adhoqu,   jaux,
 205      >                ulsort, langue, codret )
 206 c
 207       endif
 208 c
 209       if ( nbheto.ne.0 ) then
 210 c
 211 #ifdef _DEBUG_HOMARD_
 212       write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
 213 #endif
 214         iaux = 2
 215         call utad02 ( iaux, nhhexa,
 216      >                phethe, pquahe, jaux  , jaux,
 217      >                  jaux,   jaux,   jaux,
 218      >                  jaux,   jaux,   jaux,
 219      >                  jaux,   jaux,   jaux,
 220      >                ulsort, langue, codret )
 221 c
 222       endif
 223 c
 224 c
 225       endif
 226 c
 227       if ( codret.eq.0 ) then
 228 c
 229 #ifdef _DEBUG_HOMARD_
 230       write (ulsort,texte(langue,3)) 'UTAD04', nompro
 231 #endif
 232       iaux = 3
 233       call utad04 ( iaux, nhvois,
 234      >                jaux,   jaux, pposif, pfacar,
 235      >                jaux,   jaux,
 236      >                jaux,   jaux,   jaux,   jaux,
 237      >                jaux,   jaux,   jaux,
 238      >                jaux,   jaux,   jaux,
 239      >                jaux,   jaux,   jaux,
 240      >                jaux,   jaux,   jaux,
 241      >              ulsort, langue, codret )
 242 c
 243       endif
 244 c
 245       if ( codret.eq.0 ) then
 246 c
 247       ntrav1 = taopts(11)
 248       call gmadoj ( ntrav1, pdecar, iaux, codre1 )
 249       ntrav2 = taopts(12)
 250       call gmadoj ( ntrav2, pdecfa, iaux, codre2 )
 251 c
 252       codre0 = min ( codre1, codre2 )
 253       codret = max ( abs(codre0), codret,
 254      >               codre1, codre2 )
 255 c
 256       endif
 257 c
 258 c====
 259 c 3. impressions vraies
 260 c====
 261 #ifdef _DEBUG_HOMARD_
 262       write (ulsort,90002) '3. impressions vraies ; codret', codret
 263 #endif
 264 c
 265       if ( codret.eq.0 ) then
 266 c
 267       if ( avappr.eq.1 .or. avappr.eq.2 ) then
 268         write (ulsort,texte(langue,3+avappr)) nmprde
 269       else
 270         write (ulsort,texte(langue,10)) nmprde, avappr
 271       endif
 272 c
 273       iaux = 3*5
 274 #ifdef _DEBUG_HOMARD_
 275       write (ulsort,texte(langue,3)) 'DELIS1', nompro
 276 #endif
 277       call delis1
 278      >      ( iaux,
 279      >        imem(pdecar), imem(pdecfa),
 280      >        imem(pposif), imem(pfacar), imem(phetar), imem(pmerar),
 281      >        imem(phettr), imem(pnivtr),
 282      >        imem(phetqu), imem(pnivqu),
 283      >        ulsort, langue, codret )
 284 c
 285       endif
 286 c
 287 c====
 288 c 4. la fin
 289 c====
 290 c
 291       if ( codret.ne.0 ) then
 292 c
 293 #include "envex2.h"
 294 c
 295       write (ulsort,texte(langue,1)) 'Sortie', nompro
 296       write (ulsort,texte(langue,2)) codret
 297 c
 298       endif
 299 c
 300 #ifdef _DEBUG_HOMARD_
 301       write (ulsort,texte(langue,1)) 'Sortie', nompro
 302       call dmflsh (iaux)
 303 #endif
 304 c
 305       end