src/tool/Information/infcas.F

   1       subroutine infcas ( nomail, nosolu,
   2      >                    ulfido, ulenst, ulsost,
   3      >                    lgetco, taetco,
   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 : Fichiers Champs ASCII
  26 c   --            -        -      --
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . nomail . e   . char8  . nom de l'objet maillage homard iteration n .
  32 c . nosolu . e   . char8  . nom de l'objet solution                    .
  33 c . ulfido . e   .   1    . unite logique du fichier de donnees correct.
  34 c . ulenst . e   .   1    . unite logique de l'entree standard         .
  35 c . ulsost . e   .   1    . unite logique de la sortie standard        .
  36 c . lgetco . e   .   1    . longueur du tableau de l'etat courant      .
  37 c . taetco . e   . lgetco . tableau de l'etat courant                  .
  38 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  39 c . langue . e   .    1   . langue des messages                        .
  40 c .        .     .        . 1 : francais, 2 : anglais                  .
  41 c . codret . es  .    1   . code de retour des modules                 .
  42 c .        .     .        . 0 : pas de probleme                        .
  43 c .        .     .        . 2 : probleme dans les memoires             .
  44 c .        .     .        . 3 : probleme dans les fichiers             .
  45 c .        .     .        . 5 : probleme autre                         .
  46 c ______________________________________________________________________
  47 c
  48 c====
  49 c 0. declarations et dimensionnement
  50 c====
  51 c
  52 c 0.1. ==> generalites
  53 c
  54       implicit none
  55       save
  56 c
  57       character*6 nompro
  58       parameter ( nompro = 'INFCAS' )
  59 c
  60 cfonc      integer nbtych
  61 cfonc      parameter ( nbtych = 5 )
  62 c
  63 #include "nblang.h"
  64 c
  65 c 0.2. ==> communs
  66 c
  67 #include "envex1.h"
  68 c
  69 #include "gmenti.h"
  70 #include "gmreel.h"
  71 #include "gmstri.h"
  72 c
  73 #include "nombtr.h"
  74 #include "nombqu.h"
  75 #include "nombte.h"
  76 #include "envca1.h"
  77 #include "nomber.h"
  78 #include "nbutil.h"
  79 c
  80 c 0.3. ==> arguments
  81 c
  82       character*8 nomail, nosolu
  83 c
  84       integer ulfido, ulenst, ulsost
  85       integer lgetco
  86       integer taetco(lgetco)
  87 c
  88       integer ulsort, langue, codret
  89 c
  90 c 0.4. ==> variables locales
  91 c
  92       integer codava
  93       integer nretap, nrsset
  94       integer iaux, jaux
  95 c
  96       integer pcoono, psomar
  97       integer pnp2ar, phetar, pmerar, pposif, pfacar
  98       integer phettr, paretr, pnivtr
  99       integer advotr
 100       integer phetqu, parequ, pnivqu
 101       integer ptrite, phette
 102       integer adnbrn
 103       integer adnohn, adnocn, adnoin, lgnoin
 104       integer adtrhn, adtrcn, adtrin, lgtrin
 105       integer adquhn, adqucn, adquin, lgquin
 106       integer option
 107       integer numfic
 108 c
 109       integer nbcham, nbfonc, nbprof, nblopg
 110       integer aninch, aninfo, aninpr, adinlg
 111       integer nrocha, nrocmp, nrotab
 112 c
 113       integer decanu(-1:7)
 114 c
 115       character*6 saux06
 116       character*8 norenu
 117       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 118       character*8 nhtetr, nhhexa, nhpyra, nhpent
 119       character*8 nhelig
 120       character*8 nhvois, nhsupe, nhsups
 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       codava = codret
 134 c
 135 c=======================================================================
 136       if ( codava.eq.0 ) then
 137 c=======================================================================
 138 c
 139 c 1.1. ==> les messages
 140 c
 141 #include "impr01.h"
 142 c
 143 #ifdef _DEBUG_HOMARD_
 144       write (ulsort,texte(langue,1)) 'Entree', nompro
 145       call dmflsh (iaux)
 146 #endif
 147 c
 148       texte(1,4) = '(a6,'' FICHIER ASCII POUR GRAPHIQUE'')'
 149       texte(1,5) = '(35(''=''),/)'
 150       texte(1,10) = '(''Lancement du trace numero'',i3)'
 151 c
 152       texte(2,4) = '(a6,'' ASCII FILE FOR GRAPHIC'')'
 153       texte(2,5) = '(29(''=''),/)'
 154       texte(2,10) = '(''Beginning of writings #'',i3)'
 155 c
 156 #include "impr03.h"
 157 c
 158 c 1.4. ==> le numero de sous-etape
 159 c
 160       nretap = taetco(1)
 161       nrsset = taetco(2) + 1
 162       taetco(2) = nrsset
 163 c
 164       call utcvne ( nretap, nrsset, saux06, iaux, codret )
 165 c
 166 c 1.5 ==> le titre
 167 c
 168       write (ulsort,texte(langue,4)) saux06
 169       write (ulsort,texte(langue,5))
 170 c
 171 c====
 172 c 2. recuperation des pointeurs
 173 c====
 174 c
 175 c 2.1. ==> structure generale
 176 c
 177       if ( codret.eq.0 ) then
 178 c
 179 #ifdef _DEBUG_HOMARD_
 180       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 181 #endif
 182       call utnomh ( nomail,
 183      >                sdim,   mdim,
 184      >               degre, maconf, homolo, hierar,
 185      >              rafdef, nbmane, typcca, typsfr, maextr,
 186      >              mailet,
 187      >              norenu,
 188      >              nhnoeu, nhmapo, nharet,
 189      >              nhtria, nhquad,
 190      >              nhtetr, nhhexa, nhpyra, nhpent,
 191      >              nhelig,
 192      >              nhvois, nhsupe, nhsups,
 193      >              ulsort, langue, codret)
 194 c
 195       endif
 196 c
 197 c 2.2. ==> tableaux
 198 #ifdef _DEBUG_HOMARD_
 199       write (ulsort,*) '2.2. Tableaux ; codret = ', codret
 200 #endif
 201 c
 202       if ( codret.eq.0 ) then
 203 c
 204 #ifdef _DEBUG_HOMARD_
 205       write (ulsort,texte(langue,3)) 'UTAD01', nompro
 206 #endif
 207       iaux = 3
 208       call utad01 ( iaux, nhnoeu,
 209      >                jaux,
 210      >                jaux,   jaux,   jaux,
 211      >              pcoono,   jaux,   jaux,  jaux,
 212      >              ulsort, langue, codret )
 213 c
 214 #ifdef _DEBUG_HOMARD_
 215       write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
 216 #endif
 217       iaux = 10
 218       if ( degre.eq.2 ) then
 219         iaux = iaux*13
 220       endif
 221       call utad02 (   iaux, nharet,
 222      >              phetar, psomar,   jaux, pmerar,
 223      >                jaux,   jaux,   jaux,
 224      >                jaux, pnp2ar,   jaux,
 225      >                jaux,   jaux,   jaux,
 226      >              ulsort, langue, codret )
 227 c
 228       if ( nbtrto.ne.0 ) then
 229 c
 230 #ifdef _DEBUG_HOMARD_
 231       write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
 232 #endif
 233         iaux = 22
 234         call utad02 (   iaux, nhtria,
 235      >                phettr, paretr,   jaux,   jaux,
 236      >                  jaux,   jaux,   jaux,
 237      >                pnivtr,   jaux,   jaux,
 238      >                  jaux,   jaux,   jaux,
 239      >                ulsort, langue, codret )
 240 c
 241       endif
 242 c
 243       if ( nbquto.ne.0 ) then
 244 c
 245 #ifdef _DEBUG_HOMARD_
 246       write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
 247 #endif
 248         iaux = 22
 249         call utad02 (   iaux, nhquad,
 250      >                phetqu, parequ,   jaux,   jaux,
 251      >                  jaux,   jaux,   jaux,
 252      >                pnivqu,   jaux,   jaux,
 253      >                  jaux,   jaux,   jaux,
 254      >                ulsort, langue, codret )
 255 c
 256       endif
 257 c
 258       if ( nbteto.ne.0 ) then
 259 c
 260 #ifdef _DEBUG_HOMARD_
 261       write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
 262 #endif
 263         iaux = 2
 264         call utad02 (   iaux, nhtetr,
 265      >                phette, ptrite, jaux  , jaux,
 266      >                  jaux,   jaux,   jaux,
 267      >                  jaux,   jaux,   jaux,
 268      >                  jaux,   jaux,   jaux,
 269      >                ulsort, langue, codret )
 270 c
 271       endif
 272 c
 273       endif
 274 c
 275 c 2.3. ==> les voisinages
 276 c
 277       if ( codret.eq.0 ) then
 278 c
 279 #ifdef _DEBUG_HOMARD_
 280       write (ulsort,texte(langue,3)) 'UTAD04', nompro
 281 #endif
 282       iaux = 3
 283       if ( nbteto.ne.0 ) then
 284         iaux = iaux*5
 285       endif
 286       call utad04 ( iaux, nhvois,
 287      >                jaux,   jaux, pposif, pfacar,
 288      >              advotr,   jaux,
 289      >                jaux,   jaux,   jaux,   jaux,
 290      >                jaux,   jaux,   jaux,
 291      >                jaux,   jaux,   jaux,
 292      >                jaux,   jaux,   jaux,
 293      >                jaux,   jaux,   jaux,
 294      >              ulsort, langue, codret )
 295 c
 296       endif
 297 c
 298 c 2.4. ===> tableaux lies a la renumerotation
 299 c
 300       if ( codret.eq.0 ) then
 301 c
 302 #ifdef _DEBUG_HOMARD_
 303       write (ulsort,texte(langue,3)) 'UTRE03_no', nompro
 304 #endif
 305       iaux = -1
 306       jaux = 210
 307       call utre03 ( iaux, jaux, norenu,
 308      >              renoac, renoto, adnohn, adnocn,
 309      >              ulsort, langue, codret)
 310 c
 311       endif
 312 c
 313       if ( codret.eq.0 ) then
 314 c
 315 #ifdef _DEBUG_HOMARD_
 316       write (ulsort,texte(langue,3)) 'UTRE04_no', nompro
 317 #endif
 318       iaux = -1
 319       jaux = -11
 320       call utre04 ( iaux, jaux, norenu,
 321      >              lgnoin, adnoin,
 322      >              ulsort, langue, codret)
 323 c
 324       endif
 325 c
 326       if ( retrac.ne.0 ) then
 327 c
 328         if ( codret.eq.0 ) then
 329 c
 330 #ifdef _DEBUG_HOMARD_
 331         write (ulsort,texte(langue,3)) 'UTRE03_tr', nompro
 332 #endif
 333         iaux = 2
 334         jaux = -210
 335         call utre03 ( iaux, jaux, norenu,
 336      >                retrac, retrto, adtrhn, adtrcn,
 337      >                ulsort, langue, codret)
 338 c
 339         endif
 340 c
 341         if ( codret.eq.0 ) then
 342 c
 343 #ifdef _DEBUG_HOMARD_
 344       write (ulsort,texte(langue,3)) 'UTRE04_tr', nompro
 345 #endif
 346         iaux = 2
 347         jaux = -11
 348         call utre04 ( iaux, jaux, norenu,
 349      >                lgtrin, adtrin,
 350      >                ulsort, langue, codret)
 351 c
 352        endif
 353 c
 354       endif
 355 c
 356       if ( requac.ne.0 ) then
 357 c
 358         if ( codret.eq.0 ) then
 359 c
 360 #ifdef _DEBUG_HOMARD_
 361         write (ulsort,texte(langue,3)) 'UTRE03_qu', nompro
 362 #endif
 363         iaux = 4
 364         jaux = -210
 365         call utre03 ( iaux, jaux, norenu,
 366      >                requac, requto, adquhn, adqucn,
 367      >                ulsort, langue, codret)
 368 c
 369         endif
 370 c
 371         if ( codret.eq.0 ) then
 372 c
 373 #ifdef _DEBUG_HOMARD_
 374       write (ulsort,texte(langue,3)) 'UTRE04_qu', nompro
 375 #endif
 376         iaux = 4
 377         jaux = -11
 378         call utre04 ( iaux, jaux, norenu,
 379      >                lgquin, adquin,
 380      >                ulsort, langue, codret)
 381 c
 382         endif
 383 c
 384       endif
 385 c
 386       if ( codret.eq.0 ) then
 387 c
 388 cgn      call gmprsx ( nompro, norenu//'.Nombres' )
 389       call gmadoj ( norenu//'.Nombres', adnbrn, iaux, codret )
 390 c
 391       endif
 392 c
 393       if ( codret.eq.0 ) then
 394 c
 395 #ifdef _DEBUG_HOMARD_
 396       write (ulsort,texte(langue,3)) 'UTNBMH', nompro
 397 #endif
 398       call utnbmh ( imem(adnbrn),
 399      >                iaux,   iaux,   iaux,
 400      >                iaux,   iaux,   iaux,
 401      >                iaux,   iaux,   iaux,
 402      >                iaux,   iaux,   iaux,   iaux,
 403      >              nbmapo, nbsegm, nbtria, nbtetr,
 404      >              nbquad, nbhexa, nbpent, nbpyra,
 405      >                iaux,   iaux,
 406      >                iaux,   iaux,
 407      >              ulsort, langue, codret )
 408 #ifdef _DEBUG_HOMARD_
 409       write(ulsort,90002) 'nbmapo', nbmapo
 410       write(ulsort,90002) 'nbsegm', nbsegm
 411       write(ulsort,90002) 'nbtria', nbtria
 412       write(ulsort,90002) 'nbtetr', nbtetr
 413       write(ulsort,90002) 'nbquad', nbquad
 414       write(ulsort,90002) 'nbhexa', nbhexa
 415       write(ulsort,90002) 'nbpent', nbpent
 416       write(ulsort,90002) 'nbpyra', nbpyra
 417 #endif
 418 c
 419       decanu(-1) = 0
 420       decanu(3) = 0
 421       decanu(2) = nbtetr
 422       decanu(1) = nbtetr + nbtria
 423       decanu(0) = nbtetr + nbtria + nbsegm
 424       decanu(4) = nbtetr + nbtria + nbsegm + nbmapo
 425       decanu(6) = nbtetr + nbtria + nbsegm + nbmapo + nbquad
 426       decanu(5) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa
 427       decanu(7) = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa
 428      >          + nbpyra
 429 c
 430       endif
 431 c
 432 c 2.5. ===> tableaux lies a la solution eventuelle
 433 c
 434       if ( codret.eq.0 ) then
 435 c
 436 #ifdef _DEBUG_HOMARD_
 437       call gmprsx (nompro,nosolu)
 438       call gmprsx (nompro,nosolu//'.InfoCham')
 439       call gmprsx (nompro,nosolu//'.InfoPaFo')
 440       call gmprsx (nompro,nosolu//'.InfoProf')
 441       call gmprsx (nompro,nosolu//'.InfoLoPG')
 442 #endif
 443 c
 444 #ifdef _DEBUG_HOMARD_
 445       write (ulsort,texte(langue,3)) 'UTCASO', nompro
 446 #endif
 447       call utcaso ( nosolu,
 448      >              nbcham, nbfonc, nbprof, nblopg,
 449      >              aninch, aninfo, aninpr, adinlg,
 450      >              ulsort, langue, codret )
 451 c
 452       endif
 453 c
 454       if ( codret.eq.0 ) then
 455 c
 456       if ( nbcham.eq.0 ) then
 457         codret = 0
 458         goto 60
 459       endif
 460 c
 461       endif
 462 c
 463 c====
 464 c 3. initialisations
 465 c====
 466 #ifdef _DEBUG_HOMARD_
 467       write (ulsort,*) '3. initialisations ; codret = ', codret
 468 #endif
 469 c
 470       numfic = 0
 471 c
 472 c====
 473 c 4. questions - reponses pour les sorties
 474 c====
 475 #ifdef _DEBUG_HOMARD_
 476       write (ulsort,*) '4. questions - reponses ; codret = ', codret
 477 #endif
 478 c
 479    40 continue
 480 c
 481       if ( codret.eq.0 ) then
 482 c
 483 #ifdef _DEBUG_HOMARD_
 484       write (ulsort,texte(langue,3)) 'INFCA1', nompro
 485 #endif
 486       call infca1 ( numfic, option,
 487      >              nbcham, smem(aninch),
 488      >              nrocha, nrocmp, nrotab,
 489      >              ulfido, ulenst, ulsost,
 490      >              ulsort, langue, codret )
 491 c
 492       endif
 493 c
 494       if ( codret.eq.0 ) then
 495 c
 496       if ( option.eq.0 ) then
 497         codret = 0
 498         goto 60
 499       endif
 500 c
 501       endif
 502 c
 503 c====
 504 c 5. ecriture des valeurs
 505 c====
 506 #ifdef _DEBUG_HOMARD_
 507       write (ulsort,*) '5. ecriture des valeurs ; codret = ', codret
 508 #endif
 509 c
 510       if ( codret.eq.0 ) then
 511 c
 512 #ifdef _DEBUG_HOMARD_
 513       write (ulsort,texte(langue,3)) 'INFCA2', nompro
 514 #endif
 515         call infca2 ( numfic,
 516      >                nbcham, smem(aninch),
 517      >                nrocha, nrocmp, nrotab,
 518      >                rmem(pcoono),
 519      >                imem(adnocn), imem(adtrcn), imem(adqucn),
 520      >                imem(adnohn), imem(adtrhn), imem(adquhn),
 521      >                lgnoin, lgtrin, lgquin,
 522      >                imem(adnoin), imem(adtrin), imem(adquin),
 523      >                decanu,
 524      >                ulsort, langue, codret )
 525 c
 526       endif
 527 c
 528       if ( codret.eq.0 ) then
 529 c
 530       goto 40
 531 c
 532       endif
 533 c
 534 c====
 535 c 6. la fin
 536 c====
 537 #ifdef _DEBUG_HOMARD_
 538       write (ulsort,*) '6. La fin ; codret = ', codret
 539 #endif
 540 c
 541    60 continue
 542 c
 543       write (ulsort,*) ' '
 544 c
 545 c 6.1. ==> message si erreur
 546 c
 547       if ( codret.ne.0 ) then
 548 c
 549 #include "envex2.h"
 550 c
 551       write (ulsort,texte(langue,1)) 'Sortie', nompro
 552       write (ulsort,texte(langue,2)) codret
 553 c
 554       endif
 555 c
 556 #ifdef _DEBUG_HOMARD_
 557       write (ulsort,texte(langue,1)) 'Sortie', nompro
 558       call dmflsh (iaux)
 559 #endif
 560 c
 561 c=======================================================================
 562       endif
 563 c=======================================================================
 564 c
 565       end