src/tool/Utilitaire/utsex0.F

   1       subroutine utsex0 ( nocsol, option,
   2      >                    ulsort, langue, codret )
   3 c ______________________________________________________________________
   4 c
   5 c                             H O M A R D
   6 c
   7 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   8 c
   9 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  10 c aupres des huissiers de justice Simart et Lavoir a Clamart
  11 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  12 c aupres des huissiers de justice
  13 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  14 c
  15 c    HOMARD est une marque deposee d'Electricite de France
  16 c
  17 c Copyright EDF 1996
  18 c Copyright EDF 1998
  19 c Copyright EDF 2002
  20 c Copyright EDF 2020
  21 c ______________________________________________________________________
  22 c
  23 c    UTilitaire - Solution - EXtrusion - phase 0
  24 c    --           -          --                -
  25 c ______________________________________________________________________
  26 c .        .     .        .                                            .
  27 c .  nom   . e/s . taille .           description                      .
  28 c .____________________________________________________________________.
  29 c . nocsol . e   . char8  . nom de l'objet solution a modifier         .
  30 c . option . e   .    1   . option de la modification                  .
  31 c .        .     .        . 1 : passage du 3D au 2D                    .
  32 c .        .     .        . 2 : passage du 2D au 3D                    .
  33 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  34 c . langue . e   .    1   . langue des messages                        .
  35 c .        .     .        . 1 : francais, 2 : anglais                  .
  36 c . codret . es  .    1   . code de retour des modules                 .
  37 c .        .     .        . 0 : pas de probleme                        .
  38 c .        .     .        . 1 : probleme                               .
  39 c ______________________________________________________________________
  40 c
  41 c====
  42 c 0. declarations et dimensionnement
  43 c====
  44 c
  45 c 0.1. ==> generalites
  46 c
  47       implicit none
  48       save
  49 c
  50       character*6 nompro
  51       parameter ( nompro = 'UTSEX0' )
  52 c
  53 #include "nblang.h"
  54 #include "consts.h"
  55 #include "meddc0.h"
  56 c
  57 c 0.2. ==> communs
  58 c
  59 #include "envex1.h"
  60 #include "op0012.h"
  61 #include "nbutil.h"
  62 #include "nombqu.h"
  63 #include "nombhe.h"
  64 c
  65 #include "gmstri.h"
  66 c
  67 c 0.3. ==> arguments
  68 c
  69       integer option
  70 c
  71       character*8 nocsol
  72 c
  73       integer ulsort, langue, codret
  74 c
  75 c 0.4. ==> variables locales
  76 c
  77       integer iaux
  78       integer tbiaux(2,3)
  79 c
  80       integer edsuav, edsuap, edsaav, edsaap, nbenti
  81       integer nuedel
  82 c
  83       integer nbcham, nbpafo, nbprof, nblopg
  84       integer adinch, adinpf, adinpr, adinlg
  85 c
  86       integer nbmess
  87       parameter ( nbmess = 20 )
  88       character*80 texte(nblang,nbmess)
  89 c
  90 c 0.5. ==> initialisations
  91 c ______________________________________________________________________
  92 c
  93 c====
  94 c 1. initialisations
  95 c====
  96 c
  97 #include "impr01.h"
  98 c
  99 #ifdef _DEBUG_HOMARD_
 100       write (ulsort,texte(langue,1)) 'Entree', nompro
 101       call dmflsh (iaux)
 102 #endif
 103 c
 104       texte(1,4) = '(''Solution sur le domaine '',i1,''D'')'
 105       texte(1,6) = '(''Option de conversion '',i8,'' invalide.'')'
 106       texte(1,7) = '(''Il faut 1 ou 2.'')'
 107       texte(1,8) = '(''Nombre de champs               : '', i3)'
 108       texte(1,9) = '(''Nombre de paquets de fonctions : '', i3)'
 109 c
 110       texte(2,4) = '(''Solution to convert for '',i1,''D'')'
 111       texte(2,6) = '(''Option for conversion '',i8,'' is uncorrect.'')'
 112       texte(2,7) = '(''1 or 2 is needed.'')'
 113       texte(2,8) = '(''Number of fields            : '', i3)'
 114       texte(2,9) = '(''Number of packs of functions: '', i3)'
 115 c
 116 #include "impr03.h"
 117 c
 118 c====
 119 c 2. Les types MED a echanger
 120 c====
 121 c
 122       if ( option.eq.1 ) then
 123         tbiaux(1,1) = edhex8
 124         tbiaux(1,2) = edqua4
 125         tbiaux(1,3) = nbquad
 126         tbiaux(2,1) = edpen6
 127         tbiaux(2,2) = edtri3
 128         tbiaux(2,3) = nbtria
 129       elseif ( option.eq.2 ) then
 130         tbiaux(1,1) = edqua4
 131         tbiaux(1,2) = edhex8
 132         tbiaux(1,3) = nbhexa
 133         tbiaux(2,1) = edtri3
 134         tbiaux(2,2) = edpen6
 135         tbiaux(2,3) = nbpent
 136       else
 137         write (ulsort,texte(langue,6)) option
 138         write (ulsort,texte(langue,7))
 139         codret = 1
 140       endif
 141 c
 142 #ifdef _DEBUG_HOMARD_
 143 10000 format(43('='))
 144       write (ulsort,10000)
 145       write (ulsort,90002) 'nbquac', nbquac, nbquto
 146       write (ulsort,90002) 'nbheac', nbheac, nbheto
 147       write (ulsort,90002) 'nbtria', nbtria
 148       write (ulsort,90002) 'nbquad', nbquad
 149       write (ulsort,90002) 'nbhexa', nbhexa
 150       write (ulsort,90002) 'nbpent', nbpent
 151       write (ulsort,texte(langue,4)) 1+fp0012(option)
 152       write (ulsort,90002) 'tbiaux', tbiaux
 153       call gmprsx (nompro//' - nocsol', nocsol )
 154 cgn      call gmprsx ('nocsol.InfoCham', nocsol//'.InfoCham' )
 155 cgn      call gmprsx (' ', '%%%%%%18' )
 156 cgn      call gmprsx ('nocsol.InfoPaFo', nocsol//'.InfoPaFo' )
 157       if ( option.eq.22 ) then
 158         call gmprsx (' ', '%%%%%%22' )
 159         call gmprsx (' ', '%%Fo0054' )
 160         call gmprsx (' ', '%%%%%%20' )
 161         call gmprsx (' ', '%%%%%%20.ValeursR' )
 162         call gmprsx (' ', '%%%%%%21' )
 163         call gmprsx (' ', '%%%%%%21.ValeursR' )
 164       elseif ( option.eq.11 ) then
 165         call gmprsx (' ', '%%%%%%25' )
 166         call gmprsx (' ', '%%Fo0059' )
 167         call gmprsx (' ', '%%%%%%28' )
 168         call gmprsx (' ', '%%%%%%28.ValeursR' )
 169         call gmprsx (' ', '%%%%%%30' )
 170         call gmprsx (' ', '%%%%%%30.ValeursR' )
 171       endif
 172 cgn      call gmprsx (nompro, nocsol//'.InfoProf' )
 173       write (ulsort,10000)
 174 #endif
 175 c
 176 c====
 177 c 3. recuperation des pointeurs lies a la solution
 178 c====
 179 #ifdef _DEBUG_HOMARD_
 180       write (ulsort,90002) '3. recuperation ; codret', codret
 181 #endif
 182 c
 183       if ( codret.eq.0 ) then
 184 c
 185       call utcaso ( nocsol,
 186      >              nbcham, nbpafo, nbprof, nblopg,
 187      >              adinch, adinpf, adinpr, adinlg,
 188      >              ulsort, langue, codret )
 189 c
 190 #ifdef _DEBUG_HOMARD_
 191       write (ulsort,texte(langue,8)) nbcham
 192       write (ulsort,texte(langue,9)) nbpafo
 193 #endif
 194 c
 195       endif
 196 c
 197 c====
 198 c 4. Pour chacun des deux types de mailles
 199 c====
 200 #ifdef _DEBUG_HOMARD_
 201       write (ulsort,90002) '4. chacun des deux types ; codret', codret
 202 #endif
 203 c
 204       do 40 , nuedel = 1 , 2
 205 c
 206 c 4.1. ==> Les types de mailles a echanger
 207 c
 208         edsuav = tbiaux(nuedel,1)
 209         edsuap = tbiaux(nuedel,2)
 210         edsaav = tbiaux(fp0012(nuedel),1)
 211         edsaap = tbiaux(fp0012(nuedel),2)
 212         nbenti = tbiaux(nuedel,3)
 213 #ifdef _DEBUG_HOMARD_
 214       write (ulsort,90015) 'Passage de', edsuav,' a', edsuap
 215       write (ulsort,90015) 'Type associe de', edsaav,' a', edsaap
 216       write (ulsort,90002) 'nbenti', nbenti
 217 #endif
 218 c
 219 c 4.2. ==> exploration des paquets de fonctions
 220 #ifdef _DEBUG_HOMARD_
 221       write (ulsort,90002) '4.2. paquets ; codret', codret
 222 #endif
 223 c
 224         if ( codret.eq.0 ) then
 225 c
 226 #ifdef _DEBUG_HOMARD_
 227       write (ulsort,texte(langue,3)) 'UTSEX1', nompro
 228 #endif
 229         call utsex1 ( nbpafo, smem(adinpf),
 230      >                edsuav, edsuap, edsaav, edsaap, nbenti,
 231      >                ulsort, langue, codret )
 232 c
 233         endif
 234 c
 235 c 4.3. ==> exploration des champs
 236 #ifdef _DEBUG_HOMARD_
 237       write (ulsort,90002) '4.3. champs ; codret', codret
 238 #endif
 239 c
 240         if ( codret.eq.0 ) then
 241 c
 242 #ifdef _DEBUG_HOMARD_
 243       write (ulsort,texte(langue,3)) 'UTSEX3', nompro
 244 #endif
 245         call utsex3 ( nbcham, smem(adinch),
 246      >                edsuav, edsuap, edsaav, edsaap, nbenti,
 247      >                ulsort, langue, codret )
 248 c
 249         endif
 250 c
 251    40 continue
 252 c
 253 c====
 254 c 5. la fin
 255 c====
 256 c
 257 #ifdef _DEBUG_HOMARD_
 258       if ( codret.eq.0 ) then
 259 cgn      write (ulsort,10000)
 260       write (ulsort,texte(langue,4)) 1+option
 261       call gmprsx (nompro, nocsol )
 262       call gmprsx (nompro, nocsol//'.InfoCham' )
 263       call gmprsx (nompro, nocsol//'.InfoPaFo' )
 264       call gmprsx (nompro, nocsol//'.InfoProf' )
 265 cgn      write (ulsort,10000)
 266       endif
 267 #endif
 268 c
 269       if ( codret.ne.0 ) then
 270 c
 271 #include "envex2.h"
 272 c
 273       write (ulsort,texte(langue,1)) 'Sortie', nompro
 274       write (ulsort,texte(langue,2)) codret
 275 c
 276       endif
 277 c
 278 #ifdef _DEBUG_HOMARD_
 279       write (ulsort,texte(langue,1)) 'Sortie', nompro
 280       call dmflsh (iaux)
 281 #endif
 282 c
 283       end