src/tool/Information/infofo.F

   1       subroutine infofo ( nbfonc, nofonc,
   2      >                      typg, numcal,
   3      >                     ulecr,
   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   INFOrmation : FOnction
  26 c   ----          --
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . nbfonc . e   .   1    . nombre de fonctions                        .
  32 c . nofonc . e   . nbfonc . nom des objets qui contiennent la          .
  33 c .        .     .        . description de chaque fonction             .
  34 c . typg   . e   .   1    . type de l'entite a examiner                .
  35 c . numcal . e   .   1    . numero du calcul de l'entite a examiner    .
  36 c . ulecr  . e   .   1    . unite logique pour l'ecriture              .
  37 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  38 c . langue . e   .    1   . langue des messages                        .
  39 c .        .     .        . 1 : francais, 2 : anglais                  .
  40 c . codret . es  .    1   . code de retour des modules                 .
  41 c .        .     .        . 0 : pas de probleme                        .
  42 c .        .     .        . 2 : probleme dans les memoires             .
  43 c .        .     .        . 3 : probleme dans les fichiers             .
  44 c .        .     .        . 5 : probleme autre                         .
  45 c ______________________________________________________________________
  46 c
  47 c====
  48 c 0. declarations et dimensionnement
  49 c====
  50 c
  51 c 0.1. ==> generalites
  52 c
  53       implicit none
  54       save
  55 c
  56       character*6 nompro
  57       parameter ( nompro = 'INFOFO' )
  58 c
  59 #include "nblang.h"
  60 #include "consts.h"
  61 #include "meddc0.h"
  62 #include "esutil.h"
  63 c
  64 c 0.2. ==> communs
  65 c
  66 #include "envex1.h"
  67 c
  68 #include "gmenti.h"
  69 #include "gmstri.h"
  70 #include "gmreel.h"
  71 c
  72 c 0.3. ==> arguments
  73 c
  74       integer nbfonc
  75       integer typg, numcal
  76 c
  77       integer ulecr
  78       integer ulsort, langue, codret
  79 c
  80       character*8 nofonc(*)
  81 c
  82 c 0.4. ==> variables locales
  83 c
  84       integer iaux, jaux, kaux
  85       integer adaux1, adaux2, adaux3
  86       integer nrfonc, nrtafo
  87       integer nbpg
  88       integer advale, advalr, adobch, adprpg, adtyas
  89       integer typgeo, ngauss, nbenmx, nbvapr, nbtyas
  90       integer carsup, nbtafo, typint
  91 c
  92       integer nbcomp, nbtvch, typcha
  93       integer nrocmp, nrotch
  94       integer nument
  95       integer adnocp, adcaen, adcare, adcaca
  96       integer adlipr
  97 c
  98       character*8 nnfonc
  99       character*8 saux08
 100       character*16 nomcmp
 101       character*16 saux16
 102       character*18 unicmp
 103       character*64 nomcha, saux64, noprof
 104 c
 105       integer nbmess
 106       parameter ( nbmess = 10 )
 107       character*80 texte(nblang,nbmess)
 108 c ______________________________________________________________________
 109 c
 110 c====
 111 c 1. messages
 112 c====
 113 c
 114 #include "impr01.h"
 115 #include "infoen.h"
 116 c
 117 #ifdef _DEBUG_HOMARD_
 118       write (ulsort,texte(langue,1)) 'Entree', nompro
 119       call dmflsh (iaux)
 120 #endif
 121 c
 122       texte(1,4) = '(''Type de l''''entite a examiner   :'',i5)'
 123       texte(1,5) = '(''Numero de l''''entite a examiner :'',i5)'
 124       texte(1,6) = '(/,''Fonction numero '',i5)'
 125       texte(1,7) = '(''. Nom du profil : '',a)'
 126       texte(1,8) = '(''Incoherence dans la longueur du profil.'')'
 127 c
 128       texte(2,4) = '(''Type of entity     :'',i5)'
 129       texte(2,5) = '(''Number of entity   :'',i5)'
 130       texte(2,6) = '(/,''Functions # '',i5)'
 131       texte(2,7) = '(''. Profil name : '',a)'
 132       texte(2,8) = '(''Profile lengths are not coherent.'')'
 133 c
 134 #include "impr03.h"
 135 c
 136 #ifdef _DEBUG_HOMARD_
 137       write (ulsort,texte(langue,4)) typg
 138       write (ulsort,texte(langue,5)) numcal
 139 #endif
 140 c
 141       codret = 0
 142 c
 143 c     Pour eviter un message de ftnchek :
 144       nomcha = blan64
 145 c
 146 c====
 147 c 2. on parcourt toutes les fonctions
 148 c====
 149 c
 150       do 20 , nrfonc = 1 , nbfonc
 151 c
 152 c 2.1. ==> caracterisation de la fonction courante
 153 c
 154         if ( codret.eq.0 ) then
 155 c
 156         nnfonc = nofonc(nrfonc)
 157 c
 158 #ifdef _DEBUG_HOMARD_
 159         write (ulsort,texte(langue,6)) nrfonc
 160 cgn        call gmprsx (nompro, nnfonc )
 161 cgn        call gmprsx (nompro, nnfonc//'.ValeursR' )
 162 #endif
 163 c
 164 #ifdef _DEBUG_HOMARD_
 165         write (ulsort,texte(langue,3)) 'UTCAFO', nompro
 166 #endif
 167         call utcafo ( nnfonc,
 168      >                typcha,
 169      >                typgeo, ngauss, nbenmx, nbvapr, nbtyas,
 170      >                carsup, nbtafo, typint,
 171      >                advale, advalr, adobch, adprpg, adtyas,
 172      >                ulsort, langue, codret )
 173 c
 174         endif
 175 c
 176 #ifdef _DEBUG_HOMARD_
 177         write (ulsort,90002) 'typcha', typcha
 178         write (ulsort,90002) 'typgeo', typgeo
 179         write (ulsort,90002) 'ngauss', ngauss
 180         write (ulsort,90002) 'nbenmx', nbenmx
 181         write (ulsort,90002) 'nbvapr', nbvapr
 182         write (ulsort,90002) 'nbtyas', nbtyas
 183         write (ulsort,90002) 'carsup', carsup
 184         write (ulsort,90002) 'nbtafo', nbtafo
 185 #endif
 186 c
 187 c 2.2. ==> En l'absence de profil, le numero d'entite a rechercher est
 188 c          le numero dans le calcul qui est fourni en argument
 189 c          Avec un profil, on cherche si ce numero est present dans la
 190 c          liste. Si oui, on memorise sa position avec numcal ; si non,
 191 c          on mentionne qu'aucune valeur n'est disponible.
 192 c
 193         if ( codret.eq.0 ) then
 194 c
 195         if ( nbvapr.le.0 ) then
 196 c
 197           nument = numcal
 198 c
 199         else
 200 c
 201           saux08 = smem(adprpg)
 202 #ifdef _DEBUG_HOMARD_
 203           write (ulsort,texte(langue,3)) 'UTCAPR', nompro
 204 #endif
 205           call utcapr ( saux08,
 206      >                    iaux, noprof, adlipr,
 207      >                  ulsort, langue, codret )
 208 c
 209           if ( codret.eq.0 ) then
 210 c
 211 #ifdef _DEBUG_HOMARD_
 212           write (ulsort,texte(langue,7)) noprof
 213           call gmprot (nompro,saux08//'.ListEnti',1,50)
 214 #endif
 215           if ( iaux.ne.nbvapr ) then
 216             write (ulsort,texte(langue,8))
 217             write (ulsort,90002) 'Pour la fonction', nbvapr
 218             write (ulsort,90002) 'Pour le profil  ', iaux
 219             codret = 3
 220           endif
 221 c
 222           endif
 223 c
 224           if ( codret.eq.0 ) then
 225 c
 226           nument = 0
 227           do 220 , iaux = 0 , nbvapr-1
 228             if ( imem(adlipr+iaux).eq.numcal ) then
 229               nument = iaux+1
 230               goto 221
 231             endif
 232   220     continue
 233   221     continue
 234 c
 235           endif
 236 c
 237         endif
 238 c
 239         endif
 240 c
 241 c 2.3. ==> les valeurs
 242 c
 243         if ( codret.eq.0 ) then
 244 c
 245         if ( typgeo.eq.typg ) then
 246 c
 247 cgn          call gmprot (nompro, nnfonc//'.ValeursR',1,nbenmx*nbtafo )
 248           if ( ngauss.eq.ednopg ) then
 249             nbpg = 1
 250           else
 251             nbpg = ngauss
 252           endif
 253 c
 254           do 231 , nrtafo = 1 , nbtafo
 255 c
 256 c 2.3.1. ==> le nom du champ et de la composante
 257 c 2.3.1.1. ==> recuperation
 258 c
 259             if ( codret.eq.0 ) then
 260 c
 261             saux08 = smem(adobch+nrtafo-1)
 262 #ifdef _DEBUG_HOMARD_
 263 cgn            call gmprsx (nompro,saux08)
 264 cgn            call gmprsx (nompro,saux08//'.Nom_Comp')
 265 cgn            call gmprsx (nompro,saux08//'.Cham_Ent')
 266 cgn            call gmprsx (nompro,saux08//'.Cham_Ree')
 267             call gmprsx (nompro,saux08//'.Cham_Car')
 268             call gmprsx (nompro,'%%%%%%19')
 269             call gmprsx (nompro,'%%%%%%19.ValeursR')
 270 cgn            call gmprsx (nompro,'%%%%%%19.ValeursE')
 271 #endif
 272 #ifdef _DEBUG_HOMARD_
 273           write (ulsort,texte(langue,3)) 'UTCACH', nompro
 274 #endif
 275             call utcach ( saux08,
 276      >                    saux64,
 277      >                    nbcomp, nbtvch, typcha,
 278      >                    adnocp, adcaen, adcare, adcaca,
 279      >                    ulsort, langue, codret )
 280 c
 281             endif
 282 c
 283 cgn            write(ulsort,*) 'nbcomp = ',nbcomp , ', nbtvch = ',nbtvch
 284             if ( codret.eq.0 ) then
 285 cgn            write(ulsort,*) 'nrtafo = ',nrtafo , ', saux64 = ',saux64
 286 c
 287 c 2.3.1.2. ==> le nom du champ
 288 c
 289               if ( nrtafo.eq.1 .or. saux64.ne.nomcha ) then
 290                 nomcha = saux64
 291                 write (ulecr,30001) nomcha(1:48)
 292                 call utlgut ( iaux, nomcha, ulsort, langue, codret )
 293                 if ( iaux.gt.48 ) then
 294                   write (ulecr,30002) nomcha(49:64)
 295                 endif
 296                 nrocmp = nbcomp
 297                 nrotch = 0
 298               endif
 299 c
 300 c 2.3.1.3. ==> le pas de temps
 301 c
 302               if ( nrocmp.eq.nbcomp ) then
 303                 nrocmp = 0
 304                 nrotch = nrotch + 1
 305                 if ( imem(adcaen+nbinec*(nrotch-1)+1).eq.ednodt .and.
 306      >               imem(adcaen+nbinec*(nrotch-1)+2).eq.ednonr ) then
 307                   write(ulecr,30004)
 308                 else
 309                   write(ulecr,30003) imem(adcaen+nbinec*(nrotch-1)+1),
 310      >                               imem(adcaen+nbinec*(nrotch-1)+2)
 311                   saux16 = smem(adnocp+8+4*nbcomp)//
 312      >                     smem(adnocp+9+4*nbcomp)
 313                   if ( saux16(1:8).eq.'INCONNUE' ) then
 314                     saux16 = blan16
 315                   endif
 316                   write(ulecr,30005) rmem(adcare+nrotch-1), saux16
 317                 endif
 318               endif
 319 c
 320 c 2.3.1.4. ==> le nom et l'unite de la composante
 321 c
 322               nrocmp = nrocmp + 1
 323               nomcmp = smem(adnocp+6+2*nrocmp)//smem(adnocp+7+2*nrocmp)
 324               saux16 = smem(adnocp+6+2*nbcomp+2*nrocmp)//
 325      >                 smem(adnocp+7+2*nbcomp+2*nrocmp)
 326 c
 327               if ( saux16.eq.blan16 ) then
 328                 unicmp = blan16//'  '
 329               else
 330                 unicmp = '('//saux16//')'
 331               endif
 332 c
 333             endif
 334 c
 335 c 2.3.2. ==> la/les valeurs
 336 c
 337 #ifdef _DEBUG_HOMARD_
 338             write (ulsort,90002) 'nument', nument
 339 #endif
 340 c
 341             if ( nument.eq.0 ) then
 342 c
 343               if ( nrocmp.eq.nbcomp ) then
 344                 write (ulecr,30300)
 345               endif
 346 c
 347             else
 348 c
 349               if ( typcha.eq.edfl64 ) then
 350                 adaux1 = advalr
 351               else
 352                 adaux1 = advale
 353               endif
 354               adaux1 = adaux1 + nbtafo*nbpg*(nument-1)-1
 355 c
 356               if ( nomcmp.ne.blan16 ) then
 357                 write (ulecr,30006) nomcmp, unicmp
 358               else
 359                 if ( nbcomp.gt.1 ) then
 360                   write (ulecr,30016) nrocmp
 361                 endif
 362               endif
 363               adaux2 = adaux1 + nrtafo
 364 c
 365               if ( nbpg.eq.1 ) then
 366 c
 367                 if ( typcha.eq.edfl64 ) then
 368                   write (ulecr,30105) rmem(adaux2)
 369                 else
 370                   write (ulecr,30205) imem(adaux2)
 371                 endif
 372 c
 373               else
 374 cgn          call gmprot (nompro, nnfonc//'.ValeursR',1,nbenmx*nbtafo*nbpg )
 375                 kaux = nbpg - mod(nbpg,2)
 376                 do 232 , jaux = 1 , kaux, 2
 377                   adaux3 = adaux2 + nbtafo*jaux
 378                   if ( carsup.eq.1 ) then
 379                     if ( typcha.eq.edfl64 ) then
 380                       write (ulecr,30106) jaux, rmem(adaux3-nbtafo),
 381      >                                    jaux+1, rmem(adaux3)
 382                     else
 383                       write (ulecr,30206) jaux, imem(adaux3-nbtafo),
 384      >                                    jaux+1, imem(adaux3)
 385                     endif
 386                   else
 387                     if ( typcha.eq.edfl64 ) then
 388                       write (ulecr,30108) jaux, rmem(adaux3-nbtafo),
 389      >                                    jaux+1, rmem(adaux3)
 390                     else
 391                       write (ulecr,30208) jaux, imem(adaux3-nbtafo),
 392      >                                    jaux+1, imem(adaux3)
 393                     endif
 394                   endif
 395   232           continue
 396 c
 397                 if ( mod(nbpg,2).ne.0 ) then
 398                   adaux3 = adaux2 + nbtafo*(nbpg-1)
 399                   if ( typcha.eq.edfl64 ) then
 400                     if ( carsup.eq.1 ) then
 401                       write (ulecr,30107) nbpg, rmem(adaux3)
 402                     else
 403                       write (ulecr,30109) nbpg, rmem(adaux3)
 404                     endif
 405                   else
 406                     if ( carsup.eq.1 ) then
 407                       write (ulecr,30207) nbpg, imem(adaux3)
 408                     else
 409                       write (ulecr,30209) nbpg, imem(adaux3)
 410                     endif
 411                   endif
 412                 endif
 413 c
 414               endif
 415 c
 416             endif
 417 c
 418   231     continue
 419 c
 420         endif
 421 c
 422         endif
 423 c
 424    20 continue
 425 c
 426 c===
 427 c 3. formats
 428 c===
 429 c
 430 30001 format(
 431      >  '* Champ : ',a48,                                         '  *')
 432 30002 format(
 433      >  '*         ',a16,         '                                  *')
 434 30003 format(
 435      >  '*  Pas de temps :',i10,   ', Numero d''ordre :',i10,   '     ',
 436      >  '*')
 437 30004 format(
 438      >  '*  Sans pas de temps, ni numero d''ordre                     ',
 439      >  '*')
 440 30005 format(
 441      >  '*  Instant :', d14.7,    '  ',a16,         '                *')
 442 30006 format(
 443      >  '* . Composante : ',a16,         ' ',a18,           '        *')
 444 30016 format(
 445      >  '* . Composante numero',i3,
 446      >  ' :                                  *')
 447 30105 format(
 448      >  '*   ', d14.7,     42x,                                     '*')
 449 c            12345678901234123456789012345678901234567890123456789012
 450 30106 format(
 451      >  '*   ',2('no ',i2,' : ', d15.8,4x),    '  *')
 452 30107 format(
 453      >  '*   ','no ',i2,' : ', d15.8,33x,'*')
 454 30108 format(
 455      >  '*   ',2('pg ',i2,' : ', d15.8,4x),    '  *')
 456 30109 format(
 457      >  '*   ','pg ',i2,' : ', d15.8,33x,'*')
 458 30205 format(
 459      >  '*   ',   i14,     42x,                                     '*')
 460 30206 format(
 461      >  '*   ',2('no ',i2,' : ',   i15,4x),    '  *')
 462 30207 format(
 463      >  '*   ','no ',i2,' : ',   i15,33x,'*')
 464 30208 format(
 465      >  '*   ',2('pg ',i2,' : ',   i15,4x),    '  *')
 466 30209 format(
 467      >  '*   ','pg ',i2,' : ',   i15,33x,'*')
 468 30300 format(
 469      >  '*   Aucune valeur n''est presente.                           ',
 470      >  '*')
 471 c
 472 c====
 473 c 4. La fin
 474 c====
 475 c
 476       if ( codret.ne.0 ) then
 477 c
 478 #include "envex2.h"
 479 c
 480       write (ulsort,texte(langue,1)) 'Sortie', nompro
 481       write (ulsort,texte(langue,2)) codret
 482 c
 483       endif
 484 c
 485 #ifdef _DEBUG_HOMARD_
 486       write (ulsort,texte(langue,1)) 'Sortie', nompro
 487       call dmflsh (iaux)
 488 #endif
 489 c
 490       end