src/tool/Utilitaire/utcafo.F

   1       subroutine utcafo ( obfonc,
   2      >                    typcha,
   3      >                    typgeo, ngauss, nbenmx, nbvapr, nbtyas,
   4      >                    carsup, nbtafo, typint,
   5      >                    advale, advalr, adobch, adprpg, adtyas,
   6      >                    ulsort, langue, codret )
   7 c ______________________________________________________________________
   8 c
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c
  27 c    UTilitaire - CAracteristiques d'une FOnction
  28 c    --           --                     --
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . obfonc . e   . char8  . nom de l'objet fonction                    .
  34 c . typcha .   s .   1    . edin32/edin64/edfl64 selon entier/reel     .
  35 c . typgeo .   s .   1    . type geometrique au sens MED               .
  36 c . ngauss .   s .   1    . nombre de points de Gauss                  .
  37 c . nbenmx .   s .   1    . nombre d'entites maximum                   .
  38 c . nbvapr .   s .   1    . nombre de valeurs du profil                .
  39 c .        .     .        . -1, si pas de profil                       .
  40 c . nbtyas .   s .   1    . nombre de types de support associes        .
  41 c . carsup .   s .   1    . caracteristiques du support                .
  42 c .        .     .        . 1, si aux noeuds par elements              .
  43 c .        .     .        . 2, si aux points de Gauss, associe avec    .
  44 c .        .     .        .    n champ aux noeuds par elements         .
  45 c .        .     .        . 3 si aux points de Gauss autonome          .
  46 c .        .     .        . 0, sinon                                   .
  47 c . nbtafo .   s .   1    . nombre de tableaux de la fonction          .
  48 c . typint .   s .        . type interpolation                         .
  49 c .        .     .        . 0, si automatique                          .
  50 c .        .     .        . 1 si degre 1, 2 si degre 2,                .
  51 c .        .     .        . 3 si iso-P2                                .
  52 c . advale .   s .   1    . adresse du tableau de valeurs entieres     .
  53 c . advalr .   s .   1    . adresse du tableau de valeurs reelles      .
  54 c . adobch .   s .   1    . adresse des noms des objets 'Champ'        .
  55 c . adprpg .   s .   1    . adresse des noms des objets 'Profil',      .
  56 c .        .     .        . 'LocaPG' et fonction aux noeuds par        .
  57 c .        .     .        . elements eventuellement associes           .
  58 c . adtyas .   s .   1    . adresse des types associes                 .
  59 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  60 c . langue . e   .    1   . langue des messages                        .
  61 c .        .     .        . 1 : francais, 2 : anglais                  .
  62 c . codret . es  .    1   . code de retour des modules                 .
  63 c .        .     .        . 0 : pas de probleme                        .
  64 c .        .     .        . 1 : probleme                               .
  65 c ______________________________________________________________________
  66 c
  67 c====
  68 c 0. declarations et dimensionnement
  69 c====
  70 c
  71 c 0.1. ==> generalites
  72 c
  73       implicit none
  74       save
  75 c
  76       character*6 nompro
  77       parameter ( nompro = 'UTCAFO' )
  78 c
  79 #include "nblang.h"
  80 #include "consts.h"
  81 c
  82 c 0.2. ==> communs
  83 c
  84 #include "envex1.h"
  85 #include "meddc0.h"
  86 c
  87 c 0.3. ==> arguments
  88 c
  89       character*8 obfonc
  90 c
  91       integer typcha
  92       integer typgeo, ngauss, nbenmx, nbvapr, nbtyas
  93       integer carsup, nbtafo, typint
  94       integer advale, advalr, adobch, adprpg, adtyas
  95 c
  96       integer ulsort, langue, codret
  97 c
  98 c 0.4. ==> variables locales
  99 c
 100       integer iaux
 101       integer codre1, codre2, codre3, codre4, codre5
 102       integer codre6, codre7, codre8
 103       integer codre0
 104 c
 105       integer nbmess
 106       parameter ( nbmess = 10 )
 107       character*80 texte(nblang,nbmess)
 108 c
 109 c 0.5. ==> initialisations
 110 c ______________________________________________________________________
 111 c
 112 c====
 113 c 1. initialisations
 114 c====
 115 c
 116 #include "impr01.h"
 117 c
 118 #ifdef _DEBUG_HOMARD_
 119       write (ulsort,texte(langue,1)) 'Entree', nompro
 120       call dmflsh (iaux)
 121 #endif
 122 c
 123       texte(1,4) =
 124      > '(''Impossible de lire les attributs de l''''objet '',a)'
 125       texte(1,5) =
 126      > '(''Impossible de lire les adresses de l''''objet '',a)'
 127       texte(1,6) =
 128      > '(''Impossible de lire les valeurs de l''''objet '',a)'
 129 c
 130       texte(2,4) = '(''Attributes of object '',a,'' cannot be read.'')'
 131       texte(2,5) = '(''Adresses of object '',a,'' cannot be read.'')'
 132       texte(2,6) = '(''Values of object '',a,'' cannot be read.'')'
 133 c
 134 #include "impr03.h"
 135 c
 136 #ifdef _DEBUG_HOMARD_
 137       call gmprsx (nompro, obfonc )
 138       call gmprot (nompro, obfonc//'.ValeursR', 1, 10 )
 139       call gmprsx (nompro, obfonc//'.InfoCham' )
 140       call gmprsx (nompro, obfonc//'.InfoPrPG' )
 141       call gmprsx (nompro, obfonc//'.TypeSuAs' )
 142 #endif
 143 c
 144       codret = 0
 145 c
 146 c====
 147 c 2. caracteristiques de la fonction
 148 c====
 149 c
 150 c 2.1. ==> Les attributs
 151 c
 152       call gmliat ( obfonc, 1, typgeo, codre1 )
 153       call gmliat ( obfonc, 2, ngauss, codre2 )
 154       call gmliat ( obfonc, 3, nbenmx, codre3 )
 155       call gmliat ( obfonc, 4, nbvapr, codre4 )
 156       call gmliat ( obfonc, 5, nbtyas, codre5 )
 157       call gmliat ( obfonc, 6, carsup, codre6 )
 158       call gmliat ( obfonc, 7, nbtafo, codre7 )
 159       call gmliat ( obfonc, 8, typint, codre8 )
 160 c
 161       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 162      >               codre6, codre7, codre8 )
 163       codret = max ( abs(codre0), codret,
 164      >               codre1, codre2, codre3, codre4, codre5,
 165      >               codre6, codre7, codre8 )
 166 c
 167       if ( codret.ne.0 ) then
 168 c
 169 #include "envex2.h"
 170       write (ulsort,texte(langue,4)) obfonc
 171       endif
 172 c
 173 #ifdef _DEBUG_HOMARD_
 174       if ( codret.eq.0 ) then
 175       write (ulsort,90002) 'typgeo', typgeo
 176       write (ulsort,90002) 'ngauss', ngauss
 177       write (ulsort,90002) 'nbenmx', nbenmx
 178       write (ulsort,90002) 'nbvapr', nbvapr
 179       write (ulsort,90002) 'nbtyas', nbtyas
 180       write (ulsort,90002) 'carsup', carsup
 181       write (ulsort,90002) 'nbtafo', nbtafo
 182       write (ulsort,90002) 'typint', typint
 183       if ( nbtyas.gt.0 ) then
 184       call gmprsx (nompro, obfonc//'.TypeSuAs' )
 185       endif
 186       endif
 187 #endif
 188 c
 189 c 2.2. ==> Les adresses
 190 c
 191       if ( codret.eq.0 ) then
 192 c
 193       call gmadoj ( obfonc//'.InfoCham', adobch, iaux, codre1 )
 194       call gmadoj ( obfonc//'.InfoPrPG', adprpg, iaux, codre2 )
 195 c
 196       codre0 = min ( codre1, codre2 )
 197       codret = max ( abs(codre0), codret,
 198      >               codre1, codre2 )
 199 c
 200       if ( codret.ne.0 ) then
 201       write (ulsort,texte(langue,5)) obfonc//'.InfoCham/InfoPrPG'
 202       endif
 203 c
 204       endif
 205 c
 206       if ( codret.eq.0 ) then
 207 c
 208       call gmobal ( obfonc//'.ValeursR', codre1 )
 209       if ( codre1.eq.0 ) then
 210         call gmadoj ( obfonc//'.ValeursE', advale, iaux, codre2 )
 211         typcha = edint
 212       elseif ( codre1.eq.2 ) then
 213         codre1 = 0
 214         call gmadoj ( obfonc//'.ValeursR', advalr, iaux, codre2 )
 215         typcha = edfl64
 216       else
 217         codre1 = 2
 218       endif
 219 c
 220       codre0 = min ( codre1, codre2 )
 221       codret = max ( abs(codre0), codret,
 222      >               codre1, codre2 )
 223 c
 224 #ifdef _DEBUG_HOMARD_
 225       write (ulsort,90002) 'typcha', typcha
 226 #endif
 227 c
 228       if ( codret.ne.0 ) then
 229       write (ulsort,texte(langue,6)) obfonc//'.ValeursR/E'
 230       endif
 231 c
 232       endif
 233 c
 234       if ( nbtyas.gt.0 ) then
 235 c
 236       if ( codret.eq.0 ) then
 237 c
 238       call gmadoj ( obfonc//'.TypeSuAs', adtyas, iaux, codre0 )
 239 c
 240       codret = max ( abs(codre0), codret )
 241 c
 242       if ( codret.ne.0 ) then
 243       write (ulsort,texte(langue,5)) obfonc//'.TypeSuAs'
 244       endif
 245 c
 246       endif
 247 c
 248       endif
 249 c
 250 c====
 251 c 3. la fin
 252 c====
 253 c
 254       if ( codret.ne.0 ) then
 255 c
 256       write (ulsort,texte(langue,1)) 'Sortie', nompro
 257       write (ulsort,texte(langue,2)) codret
 258 c
 259       endif
 260 c
 261       end