src/tool/Utilitaire/utalpf.F

   1       subroutine utalpf ( obpafo,
   2      >                    nbfopa, typgpf, ngauss, carsup, typint,
   3      >                    adobfo, adtyge,
   4      >                    ulsort, langue, codret )
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c    UTilitaire - ALlocation d'un Paquet de Fonctions
  26 c    --           --              -         -
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . obpafo .   s . char8  . nom de l'objet du paquet de fonctions      .
  32 c . nbfopa . e   .   1    . nombre de fonctions dans le paquet         .
  33 c . typgpf . e   .   1    . si >0 : type geometrique s'il est unique   .
  34 c .        .     .        . si <0 : nombre de type geometriques associe.
  35 c . ngauss . e   .   1    . nombre de points de gauss                  .
  36 c . carsup . e   .   1    . caracteristiques du support                .
  37 c .        .     .        . 1, si aux noeuds par elements              .
  38 c .        .     .        . 2, si aux points de Gauss, associe avec    .
  39 c .        .     .        .    n champ aux noeuds par elements         .
  40 c .        .     .        . 3 si aux points de Gauss autonome          .
  41 c .        .     .        . 0, sinon                                   .
  42 c . typint . e   .   1    . type d'interpolation                       .
  43 c .        .     .        .  0, si automatique                         .
  44 c .        .     .        .  elements : 0 si intensif, sans orientation.
  45 c .        .     .        .             1 si extensif, sans orientation.
  46 c .        .     .        .             2 si intensif, avec orientation.
  47 c .        .     .        .             3 si extensif, avec orientation.
  48 c .        .     .        .  noeuds : 1 si degre 1                     .
  49 c .        .     .        .           2 si degre 2                     .
  50 c .        .     .        .           3 si iso-P2                      .
  51 c . adobfo .   s .   1    . adresse des noms des objets 'Fonction' et  .
  52 c .        .     .        . de l'eventuel paquet associe               .
  53 c . adtyge .   s .   1    . adresse des types geometriques             .
  54 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  55 c . langue . e   .    1   . langue des messages                        .
  56 c .        .     .        . 1 : francais, 2 : anglais                  .
  57 c . codret . es  .    1   . code de retour des modules                 .
  58 c .        .     .        . 0 : pas de probleme                        .
  59 c .        .     .        . 1 : probleme                               .
  60 c ______________________________________________________________________
  61 c
  62 c====
  63 c 0. declarations et dimensionnement
  64 c====
  65 c
  66 c 0.1. ==> generalites
  67 c
  68       implicit none
  69       save
  70 c
  71       character*6 nompro
  72       parameter ( nompro = 'UTALPF' )
  73 c
  74 #include "nblang.h"
  75 #include "consts.h"
  76 #include "meddc0.h"
  77 c
  78 c 0.2. ==> communs
  79 c
  80 #include "envex1.h"
  81 c
  82 c 0.3. ==> arguments
  83 c
  84       character*8 obpafo
  85 c
  86       integer nbfopa, typgpf, ngauss, carsup, typint
  87       integer adobfo, adtyge
  88 c
  89       integer ulsort, langue, codret
  90 c
  91 c 0.4. ==> variables locales
  92 c
  93       integer iaux
  94       integer codre1, codre2, codre3, codre4, codre5
  95       integer codre0
  96 c
  97       integer nbmess
  98       parameter ( nbmess = 10 )
  99       character*80 texte(nblang,nbmess)
 100 c
 101 c 0.5. ==> initialisations
 102 c ______________________________________________________________________
 103 c
 104 c====
 105 c 1. initialisations
 106 c====
 107 c
 108 #include "impr01.h"
 109 c
 110 #ifdef _DEBUG_HOMARD_
 111       write (ulsort,texte(langue,1)) 'Entree', nompro
 112       call dmflsh (iaux)
 113 #endif
 114 c
 115       texte(1,4) = '(''Creation du paquet de fonctions : '',a)'
 116 c
 117       texte(2,4) = '(''Creation of pack of functions : '',a)'
 118 c
 119 #include "impr03.h"
 120 c
 121 c====
 122 c 2. creation de la structure generale du paquet de fonctions
 123 c====
 124 c
 125       if ( codret.eq.0 ) then
 126 c
 127       call gmalot ( obpafo, 'PackFonc', 0, iaux, codret )
 128 c
 129       endif
 130 c
 131 #ifdef _DEBUG_HOMARD_
 132       write (ulsort,texte(langue,4)) obpafo
 133 #endif
 134 c
 135 c====
 136 c 3. les caracteristiques de ce paquet de fonctions
 137 c====
 138 #ifdef _DEBUG_HOMARD_
 139       write (ulsort,*) '3. caracteristiques ; codret = ', codret
 140 #endif
 141 c
 142       if ( codret.eq.0 ) then
 143 c
 144 #ifdef _DEBUG_HOMARD_
 145       write (ulsort,90002) 'nbfopa', nbfopa
 146       write (ulsort,90002) 'typgpf', typgpf
 147       write (ulsort,90002) 'ngauss', ngauss
 148       write (ulsort,90002) 'carsup', carsup
 149       write (ulsort,90002) 'typint', typint
 150 #endif
 151 c
 152       call gmecat ( obpafo, 1, nbfopa, codre1 )
 153       call gmecat ( obpafo, 2, typgpf, codre2 )
 154       call gmecat ( obpafo, 3, ngauss, codre3 )
 155       call gmecat ( obpafo, 4, carsup, codre4 )
 156       call gmecat ( obpafo, 5, typint, codre5 )
 157 c
 158       codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 159       codret = max ( abs(codre0), codret,
 160      >               codre1, codre2, codre3, codre4, codre5 )
 161 c
 162       endif
 163 c
 164 c====
 165 c 4. les branches
 166 c====
 167 #ifdef _DEBUG_HOMARD_
 168       write (ulsort,*) '4. branches ; codret = ', codret
 169 #endif
 170 c
 171       if ( codret.eq.0 ) then
 172 c
 173       iaux = nbfopa + 1
 174       call gmaloj ( obpafo//'.Fonction', ' ', iaux, adobfo, codre0 )
 175 c
 176       codret = max ( abs(codre0), codret )
 177 c
 178       endif
 179 c
 180       if ( typgpf.lt.0 ) then
 181 c
 182         if ( codret.eq.0 ) then
 183 c
 184         iaux = abs(typgpf)
 185         call gmaloj ( obpafo//'.TypeSuAs', ' ', iaux, adtyge, codre0 )
 186 c
 187         codret = max ( abs(codre0), codret )
 188 c
 189         endif
 190 c
 191       endif
 192 c
 193 #ifdef _DEBUG_HOMARD_
 194       call gmprsx (nompro, obpafo )
 195       call gmprsx (nompro, obpafo//'.Fonction' )
 196       call gmprsx (nompro, obpafo//'.TypeSuAs' )
 197 #endif
 198 c
 199 c====
 200 c 3. la fin
 201 c====
 202 c
 203       if ( codret.ne.0 ) then
 204 c
 205 #include "envex2.h"
 206 c
 207       write (ulsort,texte(langue,1)) 'Sortie', nompro
 208       write (ulsort,texte(langue,2)) codret
 209 c
 210       endif
 211 c
 212 #ifdef _DEBUG_HOMARD_
 213       write (ulsort,texte(langue,1)) 'Sortie', nompro
 214       call dmflsh (iaux)
 215 #endif
 216 c
 217       end