src/tool/Information/infc00.F

   1       subroutine infc00 ( nbrcas, caopti, nbcham,
   2      >                    tab,
   3      >                    nocsol, nbpafo,
   4      >                    adinch, adinpf,
   5      >                    ulsort, langue, codret )
   6 c ______________________________________________________________________
   7 c
   8 c                             H O M A R D
   9 c
  10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  11 c
  12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  13 c aupres des huissiers de justice Simart et Lavoir a Clamart
  14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  15 c aupres des huissiers de justice
  16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  17 c
  18 c    HOMARD est une marque deposee d'Electricite de France
  19 c
  20 c Copyright EDF 1996
  21 c Copyright EDF 1998
  22 c Copyright EDF 2002
  23 c Copyright EDF 2020
  24 c ______________________________________________________________________
  25 c  INformation - inFormations Complementaires - phase 00
  26 c  --              -          -                       --
  27 c ______________________________________________________________________
  28 c  Allocation de la structure de l'objet solution
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . nbrcas . e   .   1    . nombre de cas :                            .
  34 c .        .     .        . 1 : niveau                                 .
  35 c .        .     .        . 2 : qualite                                .
  36 c .        .     .        . 3 : diametre                               .
  37 c .        .     .        . 4 : parente                                .
  38 c .        .     .        . 5 : voisins des recollements               .
  39 c . caopti . e   . nbrcas . 0/1 selon que le cas est retenu            .
  40 c . nbcham . e   .   1    . nombre de champs associes                  .
  41 c . tab    .  s  .(-2:7)* . i = -2 : nombre de paquets concernes       .
  42 c .        .     . nbrcas . i > -2 : nombre de valeurs pour l'entite i .
  43 c . nocsol .  s  .   1    . nom de l'objet solution cree               .
  44 c . nbpafo .  s  .   1    . nombre d'inf. sur les paquets de fonctions .
  45 c . adinch .  s  .   1    . adresse de l'information sur les champs    .
  46 c . adinpf .  s  .   1    . adresse de l'inf. sur paquets de fonctions .
  47 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  48 c . langue . e   .    1   . langue des messages                        .
  49 c .        .     .        . 1 : francais, 2 : anglais                  .
  50 c . codret . es  .    1   . code de retour des modules                 .
  51 c .        .     .        . 0 : pas de probleme                        .
  52 c .        .     .        . 5 : mauvais type de code de calcul associe .
  53 c ______________________________________________________________________
  54 c
  55 c====
  56 c 0. declarations et dimensionnement
  57 c====
  58 c
  59 c 0.1. ==> generalites
  60 c
  61       implicit none
  62       save
  63 c
  64       character*6 nompro
  65       parameter ( nompro = 'INFC00' )
  66 c
  67 #include "nblang.h"
  68 c
  69 c 0.2. ==> communs
  70 c
  71 #include "envex1.h"
  72 #include "envca1.h"
  73 #include "nombtr.h"
  74 #include "nombte.h"
  75 #include "nombqu.h"
  76 #include "nombpy.h"
  77 #include "nombhe.h"
  78 #include "nombpe.h"
  79 #include "nbutil.h"
  80 c
  81 c 0.3. ==> arguments
  82 c
  83       integer nbrcas, nbcham
  84       integer caopti(nbrcas)
  85       integer tab(-2:7,nbrcas)
  86       integer nbpafo
  87       integer adinch, adinpf
  88 c
  89       character*8 nocsol
  90 c
  91       integer ulsort, langue, codret
  92 c
  93 c 0.4. ==> variables locales
  94 c
  95       integer iaux, jaux, kaux, laux
  96       integer tabaux(6,2)
  97       integer nbprof, nblopg
  98       integer adinpr, adinlg
  99       integer ladim
 100 c
 101       integer nucas
 102 c
 103       integer nbmess
 104       parameter ( nbmess = 10 )
 105       character*80 texte(nblang,nbmess)
 106 c
 107 c 0.5. ==> initialisations
 108 c ______________________________________________________________________
 109 c
 110 c====
 111 c 1. messages
 112 c====
 113 c
 114 #include "impr01.h"
 115 #include "impr03.h"
 116 c
 117 #ifdef _DEBUG_HOMARD_
 118       write (ulsort,texte(langue,1)) 'Entree', nompro
 119       call dmflsh (iaux)
 120 #endif
 121       texte(1,4) = '(''Creation de l''''objet '', a8)'
 122 c
 123       texte(2,4) = '(''Creation of the object '', a8)'
 124 c
 125 #ifdef _DEBUG_HOMARD_
 126       write (ulsort,90002) 'nbrcas', nbrcas
 127       write (ulsort,90002) 'caopti', caopti
 128       write (ulsort,90002) 'nbcham', nbcham
 129 #endif
 130 c
 131 #ifdef _DEBUG_HOMARD_
 132       write (ulsort,90002) 'nbtria', nbtria
 133       write (ulsort,90002) 'nbquad', nbquad
 134       write (ulsort,90002) 'nbtetr', nbtetr
 135       write (ulsort,90002) 'nbpyra', nbpyra
 136       write (ulsort,90002) 'nbhexa', nbhexa
 137       write (ulsort,90002) 'nbpent', nbpent
 138 #endif
 139 c
 140       codret = 0
 141 c
 142 c====
 143 c 2. Nombre de valeurs
 144 c====
 145 c 2.1. ==> Dimension a prendre en compte
 146 c
 147       if ( nbteto.ne.0 .or. nbheto.ne.0 .or.
 148      >     nbpeto.ne.0 .or. nbpyto.ne.0 ) then
 149         ladim = 3
 150       elseif ( nbtrto.ne.0 .or. nbquto.ne.0 ) then
 151         ladim = 2
 152       else
 153         ladim = 1
 154       endif
 155 #ifdef _DEBUG_HOMARD_
 156       write (ulsort,90002) 'ladim', ladim
 157 #endif
 158 c
 159 c 2.2. ==> Decompte du nombre de valeurs
 160 c
 161       if ( ladim.le.1 ) then
 162         kaux = 0
 163       elseif ( ladim.eq.3 ) then
 164         kaux = 4
 165         tabaux(1,1) = nbtetr
 166         tabaux(1,2) = 3
 167         tabaux(2,1) = nbpyra
 168         tabaux(2,2) = 5
 169         tabaux(3,1) = nbhexa
 170         tabaux(3,2) = 6
 171         tabaux(4,1) = nbpent
 172         tabaux(4,2) = 7
 173       endif
 174       if ( ladim.ge.2 ) then
 175         kaux = kaux+1
 176         tabaux(kaux,1) = nbtria
 177         tabaux(kaux,2) = 2
 178         kaux = kaux+1
 179         tabaux(kaux,1) = nbquad
 180         tabaux(kaux,2) = 4
 181       endif
 182 c
 183 c 2.3. ==> Transfert
 184 c
 185       do 231 , iaux = -2, 7
 186         do 2311 , nucas = 1, nbrcas
 187           tab(iaux,nucas) = 0
 188           tab(iaux,nucas) = 0
 189  2311   continue
 190   231 continue
 191 c
 192       do 232 , nucas = 1, nbrcas
 193         if ( ( ladim.eq.3 .and. nucas.eq.1 ) .or. ( nucas.eq.5 ) ) then
 194           laux = kaux - 2
 195         else
 196           laux = kaux
 197         endif
 198         do 2321 , iaux = 1, laux
 199           if ( tabaux(iaux,1).gt.0 ) then
 200             jaux = tabaux(iaux,2)
 201             tab(-2,nucas) = tab(-2,nucas) + caopti(nucas)
 202             tab(jaux,nucas) = tabaux(iaux,1)*caopti(nucas)
 203           endif
 204  2321   continue
 205   232 continue
 206 c
 207 #ifdef _DEBUG_HOMARD_
 208       do 2333 , iaux = 1, nbrcas
 209       write (ulsort,90015) 'tab de', iaux,' :',
 210      >                     (tab(jaux,iaux),jaux=-2,7)
 211  2333 continue
 212 #endif
 213 c
 214 c====
 215 c 3. allocation de la structure de tete
 216 c====
 217 c
 218       nbpafo = 0
 219       do 31 , nucas = 1, nbrcas
 220         do 311 , jaux = -1, 7
 221           if ( tab(jaux,nucas).gt.0 ) then
 222             nbpafo = nbpafo + 1
 223           endif
 224   311 continue
 225    31 continue
 226 c
 227       nbprof = 0
 228       nblopg = 0
 229 #ifdef _DEBUG_HOMARD_
 230       write (ulsort,texte(langue,3)) 'UTALSO', nompro
 231 #endif
 232       call utalso ( nocsol,
 233      >              nbcham, nbpafo, nbprof, nblopg,
 234      >              adinch, adinpf, adinpr, adinlg,
 235      >              ulsort, langue, codret )
 236 c
 237 #ifdef _DEBUG_HOMARD_
 238       write (ulsort,texte(langue,4)) nocsol
 239       call gmprsx ( nompro, nocsol )
 240 #endif
 241 c
 242 c====
 243 c 4. 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