src/tool/Utilitaire/utsex1.F

   1       subroutine utsex1 ( nbpafo, nopafo,
   2      >                    edsuav, edsuap, edsaav, edsaap, nbenti,
   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    UTilitaire - Solution - EXtrusion - phase 1
  25 c    --           -          --                -
  26 c    Changement du support dans un paquet de fonctions
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . nbpafo . e   .   1    . nombre de paquets de fonctions a traiter   .
  32 c . nopafo . e   . nbpafo . nom des objets qui contiennent la          .
  33 c .        .     .        . description de chaque paquets de fonctions .
  34 c . edsuav . e   .   1    . type med avant                             .
  35 c . edsuap . e   .   1    . type med apres                             .
  36 c . edsaav . e   .   1    . type med associe avant                     .
  37 c . edsaap . e   .   1    . type med associe apres                     .
  38 c . nbenti . e   .   1    . nombre d'entites apres                     .
  39 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  40 c . langue . e   .    1   . langue des messages                        .
  41 c .        .     .        . 1 : francais, 2 : anglais                  .
  42 c . codret . es  .    1   . code de retour des modules                 .
  43 c .        .     .        . 0 : pas de probleme                        .
  44 c .        .     .        . 1 : probleme                               .
  45 c ______________________________________________________________________
  46 c
  47 c====
  48 c 0. declarations et dimensionnement
  49 c====
  50 c
  51 c 0.1. ==> generalites
  52 c
  53       implicit none
  54       save
  55 c
  56       character*6 nompro
  57       parameter ( nompro = 'UTSEX1' )
  58 c
  59 #include "nblang.h"
  60 c
  61 c 0.2. ==> communs
  62 c
  63 #include "envex1.h"
  64 c
  65 #include "gmenti.h"
  66 #include "gmstri.h"
  67 c
  68 c 0.3. ==> arguments
  69 c
  70       integer nbpafo
  71       integer edsuav, edsuap, edsaav, edsaap, nbenti
  72 c
  73       character*8 nopafo(nbpafo)
  74 c
  75       integer ulsort, langue, codret
  76 c
  77 c 0.4. ==> variables locales
  78 c
  79       integer iaux, jaux
  80 c
  81       integer nrpafo, nbsupp
  82 c
  83       integer nbfopa, nbtyas, ngauss, carsup, typint
  84       integer adobfo, adtyge
  85 c
  86       character*8 obpafo
  87 c
  88       integer nbmess
  89       parameter ( nbmess = 10 )
  90       character*80 texte(nblang,nbmess)
  91 c
  92 c 0.5. ==> initialisations
  93 c ______________________________________________________________________
  94 c
  95 c====
  96 c 1. initialisations
  97 c====
  98 c
  99 #include "impr01.h"
 100 c
 101 #ifdef _DEBUG_HOMARD_
 102       write (ulsort,texte(langue,1)) 'Entree', nompro
 103       call dmflsh (iaux)
 104 #endif
 105 c
 106       texte(1,4) = '(''Paquet de fonctions numero'',i3)'
 107 c
 108       texte(2,4) = '(''Pack of functions #'',i3)'
 109 c
 110 #include "impr03.h"
 111 c
 112 #ifdef _DEBUG_HOMARD_
 113       write (ulsort,90015) 'Passage de', edsuav,' a', edsuap
 114       write (ulsort,90015) 'S. associe. Passage de', edsaav,' a', edsaap
 115       write (ulsort,90002) 'nbenti', nbenti
 116 #endif
 117 c
 118       codret = 0
 119 c
 120 c====
 121 c 2. exploration des paquets de fonctions
 122 c====
 123 c
 124       do 20 , nrpafo = 1 , nbpafo
 125 c
 126         obpafo = nopafo(nrpafo)
 127 c
 128 #ifdef _DEBUG_HOMARD_
 129         write (ulsort,texte(langue,4)) nrpafo
 130 #endif
 131 #ifdef _DEBUG_HOMARD_
 132         call gmprsx (nompro, obpafo )
 133         call gmprsx (nompro, obpafo//'.Fonction' )
 134         call gmprsx (nompro, obpafo//'.TypeSuAs' )
 135         call gmprsx (nompro, '%%%%%%18' )
 136 #endif
 137 c
 138 c 2.1. ==> caracterisation du paquet de fonctions courant
 139 #ifdef _DEBUG_HOMARD_
 140       write (ulsort,90002) '2.1. caracterisation ; codret', codret
 141 #endif
 142 c
 143         if ( codret.eq.0 ) then
 144 c
 145 #ifdef _DEBUG_HOMARD_
 146       write (ulsort,texte(langue,3)) 'UTCAPF', nompro
 147 #endif
 148         call utcapf ( obpafo,
 149      >                nbfopa, nbtyas, ngauss, carsup, typint,
 150      >                adobfo, adtyge,
 151      >                ulsort, langue, codret )
 152 c
 153         endif
 154 c
 155 #ifdef _DEBUG_HOMARD_
 156         if ( codret.eq.0 ) then
 157         write (ulsort,90002) 'nbfopa', nbfopa
 158         write (ulsort,90002) 'nbtyas', nbtyas
 159         write (ulsort,90002) 'ngauss', ngauss
 160         write (ulsort,90002) 'carsup', carsup
 161         write (ulsort,90002) 'typint', typint
 162         endif
 163 #endif
 164 c
 165 c 2.2. ==> types de support du paquet
 166 c          Attribut 2, nbtyas :
 167 c            si >0 : le type geometrique global quand il est unique
 168 c            si <0 : le nombre total de types geometriques associe
 169 #ifdef _DEBUG_HOMARD_
 170       write (ulsort,90002) '2.2. types de support ; codret', codret
 171 #endif
 172 c
 173         if ( codret.eq.0 ) then
 174 c
 175         jaux = 0
 176         if ( nbtyas.gt.0 ) then
 177 c
 178           nbsupp = 1
 179           if ( nbtyas.eq.edsuav ) then
 180             jaux = 1
 181           endif
 182 c
 183         else
 184 c
 185           nbsupp = abs(nbtyas)
 186 c
 187           if ( codret.eq.0 ) then
 188 c
 189 #ifdef _DEBUG_HOMARD_
 190         write (ulsort,90002)
 191      >  'Supports',(imem(adtyge-1+iaux),iaux=1,nbsupp)
 192 #endif
 193 c
 194           do 22 , iaux = 1 , nbsupp
 195             if ( imem(adtyge-1+iaux).eq.edsuav ) then
 196               jaux = iaux
 197             endif
 198    22     continue
 199 c
 200           endif
 201 c
 202         endif
 203 c
 204         endif
 205 c
 206 c 2.3. ==> Si l'un des supports est le bon, changement
 207 #ifdef _DEBUG_HOMARD_
 208       write (ulsort,90002) '2.3. changement ; codret', codret
 209 #endif
 210 c
 211         if ( jaux.gt.0 ) then
 212 c
 213 c 2.3.1. ==> modification de chaque fonction du paquet courant
 214 c
 215           if ( codret.eq.0 ) then
 216 c
 217 #ifdef _DEBUG_HOMARD_
 218       write (ulsort,texte(langue,3)) 'UTSEX2', nompro
 219 #endif
 220           call utsex2 ( nbfopa, smem(adobfo),
 221      >                  edsuav, edsuap, edsaav, edsaap, nbenti,
 222      >                  ulsort, langue, codret )
 223 c
 224           endif
 225 c
 226 c 2.3.2. ==> mise a jour du support du paquet
 227 c
 228           if ( codret.eq.0 ) then
 229 c
 230           if ( nbsupp.eq.1 ) then
 231             call gmecat ( obpafo, 2, edsuap, codret )
 232           else
 233             imem(adtyge-1+jaux) = edsuap
 234           endif
 235 c
 236           endif
 237 c
 238         endif
 239 c
 240    20 continue
 241 c
 242 c====
 243 c 3. la fin
 244 c====
 245 c
 246       if ( codret.ne.0 ) then
 247 c
 248 #include "envex2.h"
 249 c
 250       write (ulsort,texte(langue,1)) 'Sortie', nompro
 251       write (ulsort,texte(langue,2)) codret
 252 c
 253       endif
 254 c
 255 #ifdef _DEBUG_HOMARD_
 256       write (ulsort,texte(langue,1)) 'Sortie', nompro
 257       call dmflsh (iaux)
 258 #endif
 259 c
 260       end