src/tool/Information/infca2.F

   1       subroutine infca2 ( numfic,
   2      >                    nbcham, nocham,
   3      >                    nrocha, nrocmp, nrotab,
   4      >                    coonoe,
   5      >                    nnoeca, ntreca, nqueca,
   6      >                    nnoeho, ntreho, nqueho,
   7      >                    lgnoin, lgtrin, lgquin,
   8      >                    nnoein, ntrein, nquein,
   9      >                    decanu,
  10      >                    ulsort, langue, codret )
  11 c ______________________________________________________________________
  12 c
  13 c                             H O M A R D
  14 c
  15 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  16 c
  17 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  18 c aupres des huissiers de justice Simart et Lavoir a Clamart
  19 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  20 c aupres des huissiers de justice
  21 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  22 c
  23 c    HOMARD est une marque deposee d'Electricite de France
  24 c
  25 c Copyright EDF 1996
  26 c Copyright EDF 1998
  27 c Copyright EDF 2002
  28 c Copyright EDF 2020
  29 c ______________________________________________________________________
  30 c
  31 c   INformation : Fichiers Champs ASCII - 2eme partie
  32 c   --            -        -      -       -
  33 c ______________________________________________________________________
  34 c .        .     .        .                                            .
  35 c .  nom   . e/s . taille .           description                      .
  36 c .____________________________________________________________________.
  37 c . numfic . es  .   1    . numero du fichier a ecrire                 .
  38 c . nbcham . e   .   1    . nombre de champs definis                   .
  39 c . nocham . e   . nbcham . nom des objets qui contiennent la          .
  40 c .        .     .        . description de chaque champ                .
  41 c . nrocha . e   .   1    . nunero du champ retenu pour le coloriage   .
  42 c .        .     .        . -1 si coloriage selon la qualite           .
  43 c . nrocmp . e   .   1    . numero de la composante retenue            .
  44 c . nrotab . e   .   1    . numero du tableau associe au pas de temps  .
  45 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  46 c .        .     . * sdim .                                            .
  47 c . nnoeca . e   . renoto . noeuds en entree dans le calcul            .
  48 c . ntreca . e   . retrto . nro des triangles dans le calcul en entree .
  49 c . nqueca . e   . requto . nro des quads dans le calcul en entree     .
  50 c . nnoeho . e   .    *   . nro des noeuds dans HOMARD en entree       .
  51 c . ntreho . e   .    *   . nro des triangles dans HOMARD en entree    .
  52 c . nqueho . e   .    *   . nro des quads dans HOMARD en entree        .
  53 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  54 c . decanu . e   .  -1:7  . decalage des numerotations selon le type   .
  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 .        .     .        . 2 : probleme dans les memoires             .
  60 c .        .     .        . 3 : probleme dans les fichiers             .
  61 c .        .     .        . 5 : probleme autre                         .
  62 c ______________________________________________________________________
  63 c
  64 c====
  65 c 0. declarations et dimensionnement
  66 c====
  67 c
  68 c 0.1. ==> generalites
  69 c
  70       implicit none
  71       save
  72 c
  73       character*6 nompro
  74       parameter ( nompro = 'INFCA2' )
  75 c
  76 #include "nblang.h"
  77 c
  78 c 0.2. ==> communs
  79 c
  80 #include "envex1.h"
  81 c
  82 #include "gmenti.h"
  83 #include "gmreel.h"
  84 c
  85 #include "nombno.h"
  86 #include "envca1.h"
  87 #include "envada.h"
  88 #include "nomber.h"
  89 c
  90 c 0.3. ==> arguments
  91 c
  92       double precision coonoe(nbnoto,sdim)
  93 c
  94       integer numfic
  95       integer nbcham
  96       integer nrocha, nrocmp, nrotab
  97       integer nnoeca(renoto), ntreca(retrto), nqueca(requto)
  98       integer nnoeho(*), ntreho(*), nqueho(*)
  99       integer lgnoin, lgtrin, lgquin
 100       integer nnoein(*), ntrein(*), nquein(*)
 101       integer decanu(-1:7)
 102 c
 103       character*8 nocham(nbcham)
 104 c
 105       integer ulsort, langue, codret
 106 c
 107 c 0.4. ==> variables locales
 108 c
 109       integer iaux
 110 c
 111       integer nuroul, lnomfl
 112       integer nbquvi, nbtrvi
 113       integer adquvi, adtrvi
 114       integer adquva, adtrva
 115       integer nbenti
 116 c
 117       character*8 saux08
 118       character*8 notrva
 119       character*20 titre0
 120       character*200 nomflo
 121 c
 122       integer nbmess
 123       parameter ( nbmess = 10 )
 124       character*80 texte(nblang,nbmess)
 125 c
 126 c 0.5. ==> initialisations
 127 c ______________________________________________________________________
 128 c
 129 c====
 130 c 1. messages
 131 c====
 132 c
 133 #include "impr01.h"
 134 c
 135 #ifdef _DEBUG_HOMARD_
 136       write (ulsort,texte(langue,1)) 'Entree', nompro
 137       call dmflsh (iaux)
 138 #endif
 139 c
 140       texte(1,9) = '(''Caracterisation de la fonction'')'
 141 c
 142       texte(2,9) = '(''Characteristics of function'')'
 143 c
 144 c====
 145 c 2. les valeurs
 146 c====
 147 c
 148 c 2.1. ==> determination de la fonction
 149 c
 150       if ( codret.eq.0 ) then
 151 c
 152 c     tableau notrva
 153       call gmalot ( notrva, 'reel    ', nbnoto, adtrva, codret )
 154 c
 155       endif
 156 c
 157       adquva = 1
 158       adquvi = 1
 159       adtrvi = 1
 160 c
 161 c 2.2. ==> recherche des valeurs du champ
 162 c          Remarque : on met une valeur bidon a nbtrvi et nbquvi pour
 163 c                     ne pas avoir de message avec ftnchek
 164 c
 165       if ( nrotab.gt.0 ) then
 166 c
 167         if ( codret.eq.0 ) then
 168 c
 169         nbtrvi = 1
 170         nbquvi = 1
 171         iaux = 2
 172 #ifdef _DEBUG_HOMARD_
 173       write (ulsort,texte(langue,3)) 'INFFRE', nompro
 174 #endif
 175         call inffre ( iaux, rmem(adtrva), rmem(adquva), titre0,
 176      >                nocham(nrocha), nrocmp, nrotab,
 177      >                nbtrvi, nbquvi,
 178      >                imem(adtrvi), imem(adquvi),
 179      >                nnoeca, ntreca, nqueca,
 180      >                nnoeho, ntreho, nqueho,
 181      >                lgnoin, lgtrin, lgquin,
 182      >                nnoein, ntrein, nquein,
 183      >                decanu,
 184      >                ulsort, langue, codret )
 185 c
 186         endif
 187 c
 188       else
 189 c
 190         codret = 12
 191 c
 192       endif
 193 c
 194 c====
 195 c 3. ecriture des valeurs
 196 c====
 197 c
 198       if ( codret.eq.0 ) then
 199 c
 200 c 3.1 ==> ouverture du fichier
 201 c
 202       if ( codret.eq.0 ) then
 203 c
 204       numfic = numfic + 1
 205 c
 206       saux08 = '        '
 207       iaux = -5
 208       call utulbi ( nuroul, nomflo, lnomfl,
 209      >                iaux, saux08, nbiter, numfic,
 210      >              ulsort, langue, codret )
 211 c
 212       endif
 213 c
 214 c 3.2. ==> ecriture
 215 c
 216       if ( codret.eq.0 ) then
 217 c
 218       nbenti = renoto
 219 c
 220       if ( sdim.eq.1 ) then
 221 c
 222         do 321 , iaux = 1 , nbenti
 223 c
 224           write (nuroul,32000) coonoe(nnoeca(iaux),1),
 225      >                         rmem(adtrva+iaux-1)
 226 c
 227   321   continue
 228 c
 229       elseif ( sdim.eq.2 ) then
 230 c
 231         do 322 , iaux = 1 , nbenti
 232 c
 233           write (nuroul,32000) coonoe(nnoeca(iaux),1),
 234      >                         coonoe(nnoeca(iaux),2),
 235      >                         rmem(adtrva+iaux-1)
 236 c
 237   322   continue
 238 c
 239       elseif ( sdim.eq.3 ) then
 240 c
 241         do 333 , iaux = 1 , nbenti
 242 c
 243           write (nuroul,32000) coonoe(nnoeca(iaux),1),
 244      >                         coonoe(nnoeca(iaux),2),
 245      >                         coonoe(nnoeca(iaux),3),
 246      >                         rmem(adtrva+iaux-1)
 247 c
 248   333   continue
 249 c
 250       else
 251 c
 252         codret = 15
 253 c
 254       endif
 255 c
 256 32000 format(10g17.9)
 257 c
 258       endif
 259 c
 260 c 3.3. ==> fermeture du fichier
 261 c
 262       if ( codret.eq.0 ) then
 263 c
 264       call gufeul ( nuroul , codret)
 265 c
 266       endif
 267 c
 268       endif
 269 c
 270 #ifdef _DEBUG_HOMARD_
 271 cgn      call gmprsx (nompro, notrvi )
 272 #endif
 273 c
 274 c====
 275 c 4. menage
 276 c====
 277 c
 278       if ( codret.eq.0 ) then
 279 c
 280       call gmlboj ( notrva, codret )
 281 c
 282       endif
 283 c
 284 c====
 285 c 5. la fin
 286 c====
 287 c
 288       if ( codret.ne.0 ) then
 289 c
 290 #include "envex2.h"
 291 c
 292       write (ulsort,texte(langue,1)) 'Sortie', nompro
 293       write (ulsort,texte(langue,2)) codret
 294 c
 295       endif
 296 c
 297 #ifdef _DEBUG_HOMARD_
 298       write (ulsort,texte(langue,1)) 'Sortie', nompro
 299       call dmflsh (iaux)
 300 #endif
 301 c
 302       end