src/tool/Utilitaire/utmcf1.F

   1       subroutine utmcf1 ( nbfran, casfre,
   2      >                    cacfpo, cacfta, casfnf,
   3      >                    nbfich,
   4      >                    nomref, lgnofi, poinno,
   5      >                    nomufi, nomstr,
   6      >                    ulsort, langue, codret )
   7 c ______________________________________________________________________
   8 c
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c
  27 c     UTilitaire : Mot-Cle - caracterisation des Frontieres - 1
  28 c     --           -   -                         -            -
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . nbfran . e   .    1   . nombre de frontieres analytiques           .
  34 c . casfre .  s  .13nbfran. caracteristiques des frontieres analytiques.
  35 c .        .     .        . 1 : 1., si cylindre                        .
  36 c .        .     .        .     2., si sphere                          .
  37 c .        .     .        .     3., si cone par  origine, axe et angle .
  38 c .        .     .        .     4., si cone par 2 centres et 2 rayons  .
  39 c .        .     .        .     5., si tore                            .
  40 c .        .     .        . de 2 a 13 :                                .
  41 c .        .     .        . . cylindre : 2,3,4 : xcentr, ycentr, zcentr.
  42 c .        .     .        .              5,6,7 : xaxe, yaxe, zaxe      .
  43 c .        .     .        .              8 :     rayon                 .
  44 c .        .     .        . . sphere   : 2,3,4 : xcentr, ycentr, zcentr.
  45 c .        .     .        .              8 :     rayon                 .
  46 c .        .     .        . . cone     : 2,3,4 : xcentr, ycentr, zcentr.
  47 c .        .     .        .              5,6,7 : xaxe, yaxe, zaxe      .
  48 c .        .     .        .              13 :    angle en degre        .
  49 c .        .     .        . . cone 2   : 2,3,4 : xcentr, ycentr, zcentr.
  50 c .        .     .        .              8 :     rayon                 .
  51 c .        .     .        .              9,10,11:xcent2, ycent2, zcent2.
  52 c .        .     .        .              12 :    rayon2                .
  53 c .        .     .        . . tore     : 2,3,4 : xcentr, ycentr, zcentr.
  54 c .        .     .        .              5,6,7 : xaxe, yaxe, zaxe      .
  55 c .        .     .        .              8 :     rayon de revolution   .
  56 c .        .     .        .              12 :    rayon primaire        .
  57 c . cacfpo .  s  .0:nbfran. pointeurs sur le tableau du nom frontieres .
  58 c . cacfta .  s  .10nbfran. taille du nom des frontieres               .
  59 c . casfnf .  s  .10nbfran. nom des frontieres                         .
  60 c . nbfich . e   .    1   . nombre de fichiers                         .
  61 c . nomref . e   . nbfich . nom de reference des fichiers              .
  62 c . lgnofi . e   . nbfich . longueurs des noms des fichiers            .
  63 c . poinno . e   .0:nbfich. pointeur dans le tableau des noms          .
  64 c . nomufi . e   . lgtanf . noms des fichiers                          .
  65 c . nomstr . e   . nbfich . nom des structures                         .
  66 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  67 c . langue . e   .    1   . langue des messages                        .
  68 c .        .     .        . 1 : francais, 2 : anglais                  .
  69 c . codret . es  .    1   . code de retour des modules                 .
  70 c .        .     .        . 0 : pas de probleme                        .
  71 c .        .     .        . 2 : probleme de lecture                    .
  72 c .        .     .        . 3 : type inconnu                           .
  73 c ______________________________________________________________________
  74 c
  75 c====
  76 c 0. declarations et dimensionnement
  77 c====
  78 c
  79 c 0.1. ==> generalites
  80 c
  81       implicit none
  82       save
  83 c
  84       character*6 nompro
  85       parameter ( nompro = 'UTMCF1' )
  86 c
  87 #include "nblang.h"
  88 #include "motcle.h"
  89 c
  90       integer nbmcle
  91       parameter ( nbmcle = 13 )
  92 c
  93 c 0.2. ==> communs
  94 c
  95 #include "envex1.h"
  96 c
  97 c 0.3. ==> arguments
  98 c
  99       integer nbfran
 100       integer nbfich
 101       integer lgnofi(nbfich), poinno(0:nbfich)
 102       integer cacfpo(0:nbfran), cacfta(10*nbfran)
 103 c
 104       character*8 nomref(nbfich), nomufi(*), nomstr(nbfich)
 105       character*8 casfnf(10*nbfran)
 106 c
 107       double precision casfre(nbmcle,*)
 108 c
 109       integer ulsort, langue, codret
 110 c
 111 c 0.4. ==> variables locales
 112 c
 113       integer iaux, jaux, kaux
 114       integer nrfich
 115       integer nrfran, tyfran
 116       integer numero, nrmcle
 117 c
 118       character*8 mclref(0:nbmcle)
 119       character*200 sau200
 120 c
 121       logical mccode(0:nbmcle)
 122       logical mccod2(0:nbmcle)
 123 c
 124       double precision daux
 125 c
 126       integer nbmess
 127       parameter ( nbmess = 10 )
 128       character*80 texte(nblang,nbmess)
 129 c
 130       character*24 messag(nblang,5)
 131 c
 132 c 0.5. ==> initialisations
 133 c ______________________________________________________________________
 134 c
 135 c====
 136 c 1. messages
 137 c====
 138 c
 139 c 1.1. ==> tout va bien
 140 c
 141       codret = 0
 142 c
 143 c 1.2. ==> les messages
 144 c
 145 #include "impr01.h"
 146 c
 147 #ifdef _DEBUG_HOMARD_
 148       write (ulsort,texte(langue,1)) 'Entree', nompro
 149       call dmflsh (iaux)
 150 #endif
 151 c
 152       texte(1,4) = '(''Nombre de frontiere(s) analytique(s) :'',i8)'
 153       texte(1,5) =
 154      > '(/,''Numero de la frontiere en cours de recherche :'',i8)'
 155       texte(1,6) = '(''Type de la frontiere : '',a)'
 156       texte(1,7) = '(''Le type '',i8,'' est inconnu.'')'
 157       texte(1,8) = '(''La valeur de '',a,'' est indecodable.'')'
 158 c
 159       texte(2,4) = '(''Number of analytical boundarie(s):'',i8)'
 160       texte(2,5) = '(/,''Search for boundary #'',i8)'
 161       texte(2,6) = '(''Type of boundary: '',a)'
 162       texte(2,7) = '(''The type #'',i8,'' is unknown.'')'
 163       texte(2,8) = '(''The value for '',a,'' cannot be uncoded.'')'
 164 c
 165 #include "impr03.h"
 166 c
 167 c                    123456789012345678901234
 168       messag(1,1) = 'Cylindre                '
 169       messag(1,2) = 'Sphere                  '
 170       messag(1,3) = 'Cone                    '
 171       messag(1,4) = 'Cone                    '
 172       messag(1,5) = 'Tore                    '
 173 c
 174       messag(2,1) = 'Cylindre                '
 175       messag(2,2) = 'Sphere                  '
 176       messag(2,3) = 'Cone                    '
 177       messag(2,4) = 'Cone                    '
 178       messag(2,5) = 'Torus                   '
 179 c
 180 c 1.3. ==> preliminaires
 181 c
 182 #ifdef _DEBUG_HOMARD_
 183       write (ulsort,texte(langue,4)) nbfran
 184 #endif
 185       mclref( 0) = mcfanm
 186       mclref( 1) = mcfaty
 187       mclref( 2) = mcfaxc
 188       mclref( 3) = mcfayc
 189       mclref( 4) = mcfazc
 190       mclref( 5) = mcfaxa
 191       mclref( 6) = mcfaya
 192       mclref( 7) = mcfaza
 193       mclref( 8) = mcfara
 194       mclref( 9) = mcfax2
 195       mclref(10) = mcfay2
 196       mclref(11) = mcfaz2
 197       mclref(12) = mcfar2
 198       mclref(13) = mcfaan
 199 c
 200 #ifdef _DEBUG_HOMARD_
 201       write(ulsort,93020) 'Mots-cles', mclref
 202 #endif
 203 c
 204       cacfpo(0) = 0
 205 c
 206 c====
 207 c 2. on parcourt toutes les posssibilites de frontieres
 208 c====
 209 c
 210       do 20 , nrfran = 1 , nbfran
 211 c
 212 #ifdef _DEBUG_HOMARD_
 213         write (ulsort,texte(langue,5)) nrfran
 214 #endif
 215 c
 216 c 2.0. ==> On n'a rien au debut
 217 c
 218         do 201 , iaux = 0 , nbmcle
 219           mccode(iaux) = .false.
 220           mccod2(iaux) = .false.
 221   201   continue
 222 c
 223         do 200 , nrfich = 1 , nbfich
 224 c
 225 c 2.1. ==> si c'est un des mots-cles possibles, on verifie si c'est
 226 c          pour la bonne frontiere
 227 c
 228           if ( codret.eq.0 ) then
 229 c
 230           nrmcle = -1
 231           do 21 , iaux = 0 , nbmcle
 232             if ( nomref(nrfich).eq.mclref(iaux) ) then
 233               nrmcle = iaux
 234               goto 211
 235             endif
 236    21     continue
 237 c
 238   211     continue
 239 c
 240           if ( nrmcle.ge.0 ) then
 241 c
 242             call utchen ( nomstr(nrfich), numero,
 243      >                    ulsort, langue, codret )
 244 c
 245             if ( nrfran.ne.numero ) then
 246               goto 200
 247             endif
 248 c
 249           else
 250 c
 251             goto 200
 252 c
 253           endif
 254 c
 255 c
 256           endif
 257 c
 258 c 2.2. ==> recherche de la valeur
 259 c 2.2.1. ==> Mise sous forme de chaine de la 3eme donnee sur la ligne
 260 c
 261           if ( codret.eq.0 ) then
 262 c
 263           iaux = poinno(nrfich-1) + 1
 264           jaux = lgnofi(nrfich)
 265           call uts8ch ( nomufi(iaux), jaux, sau200,
 266      >                  ulsort, langue, codret )
 267 c
 268           endif
 269 c
 270 c 2.2.2. ==> Conversions
 271 c
 272           if ( codret.eq.0 ) then
 273 c
 274 c 2.2.2.1. ==> Stockage du nom de la frontiere
 275 c
 276           if ( nrmcle.eq.0 ) then
 277 c
 278             iaux = mod(lgnofi(nrfich),8)
 279             kaux = (lgnofi(nrfich) - iaux)/8
 280             if ( iaux.ne.0 ) then
 281               kaux = kaux + 1
 282             endif
 283             cacfpo(nrfran) = cacfpo(nrfran-1) + kaux
 284             jaux = 1
 285             do 2221 , iaux = 1 , kaux
 286               cacfta(cacfpo(nrfran-1)+iaux) = 8
 287               casfnf(cacfpo(nrfran-1)+iaux) = sau200(jaux:jaux+7)
 288               jaux = jaux + 8
 289  2221       continue
 290             iaux = mod(lgnofi(nrfich),8)
 291             if ( iaux.ne.0 ) then
 292               cacfta(cacfpo(nrfran)) = iaux
 293             endif
 294 c
 295 c 2.2.2.2. ==> Conversion du type : entier a decoder, puis reel
 296 c
 297           elseif ( nrmcle.eq.1 ) then
 298 c
 299             call utchen ( sau200, tyfran,
 300      >                    ulsort, langue, codret )
 301 c
 302             casfre(nrmcle,nrfran) = dble(tyfran)
 303 c
 304 c 2.2.2.3. ==> Conversion des coordonnees : reel
 305 c
 306           elseif ( nrmcle.ge.2 ) then
 307 c
 308             call utchre ( sau200, daux,
 309      >                    ulsort, langue, codret )
 310             casfre(nrmcle,nrfran) = daux
 311 cgn              write (ulsort,90004) '---'//mclref(nrmcle), daux
 312 c
 313             if ( codret.ne.0 ) then
 314               write (ulsort,texte(langue,5)) nrfran
 315               write (ulsort,texte(langue,8)) mclref(nrmcle)
 316             endif
 317 c
 318           endif
 319 c
 320           endif
 321 c
 322 c 2.2.3. ==> Archivage
 323 c
 324           if ( codret.eq.0 ) then
 325 c
 326           mccode(nrmcle) = .true.
 327 c
 328           endif
 329 c
 330 c 2.3. ==> si on a tout trouve, on passe a la frontiere suivante,
 331 c          apres controle
 332 c
 333           if ( codret.eq.0 ) then
 334 c
 335           if ( mccode(1) ) then
 336 c
 337             tyfran = nint(casfre(1,nrfran))
 338 c
 339 c 2.3.1. ==> Cas du cylindre
 340 c
 341             if ( tyfran.eq.1 ) then
 342 c
 343               if ( mccode(0) .and.
 344      >             mccode(2) .and. mccode(3) .and.
 345      >             mccode(4) .and. mccode(5) .and.
 346      >             mccode(6) .and. mccode(7) .and.
 347      >             mccode(8) ) then
 348 #ifdef _DEBUG_HOMARD_
 349                 write (ulsort,texte(langue,6)) messag(langue,tyfran)
 350                 write (ulsort,90004) 'X centre', casfre(2,nrfran)
 351                 write (ulsort,90004) 'Y centre', casfre(3,nrfran)
 352                 write (ulsort,90004) 'Z centre', casfre(4,nrfran)
 353                 write (ulsort,90004) 'X axe   ', casfre(5,nrfran)
 354                 write (ulsort,90004) 'Y axe   ', casfre(6,nrfran)
 355                 write (ulsort,90004) 'Z axe   ', casfre(7,nrfran)
 356                 write (ulsort,90004) 'Rayon   ', casfre(8,nrfran)
 357 #endif
 358 c
 359                 goto 20
 360 c
 361               endif
 362 c
 363 c 2.3.2. ==> Cas de la sphere
 364 c
 365             elseif ( tyfran.eq.2 ) then
 366 c
 367               if ( mccode(0) .and.
 368      >             mccode(2) .and. mccode(3) .and.
 369      >             mccode(4) .and. mccode(8) ) then
 370 #ifdef _DEBUG_HOMARD_
 371                 write (ulsort,texte(langue,6)) messag(langue,tyfran)
 372                 write (ulsort,90004) 'X centre', casfre(2,nrfran)
 373                 write (ulsort,90004) 'Y centre', casfre(3,nrfran)
 374                 write (ulsort,90004) 'Z centre', casfre(4,nrfran)
 375                 write (ulsort,90004) 'Rayon   ', casfre(8,nrfran)
 376 #endif
 377 c
 378                 goto 20
 379 c
 380               endif
 381 c
 382 c 2.3.3. ==> Cas du cone defini par centre, axe et angle
 383 c
 384             elseif ( tyfran.eq.3 ) then
 385 c
 386               if ( mccode(0) .and.
 387      >             mccode( 2) .and. mccode( 3) .and.
 388      >             mccode( 4) .and.
 389      >             mccode( 5) .and. mccode( 6) .and.
 390      >             mccode( 7) .and. mccode(13) ) then
 391 #ifdef _DEBUG_HOMARD_
 392                 write (ulsort,texte(langue,6)) messag(langue,tyfran)
 393                 write (ulsort,90004) 'X centre', casfre( 2,nrfran)
 394                 write (ulsort,90004) 'Y centre', casfre( 3,nrfran)
 395                 write (ulsort,90004) 'Z centre', casfre( 4,nrfran)
 396                 write (ulsort,90004) 'X axe   ', casfre(5,nrfran)
 397                 write (ulsort,90004) 'Y axe   ', casfre(6,nrfran)
 398                 write (ulsort,90004) 'Z axe   ', casfre(7,nrfran)
 399                 write (ulsort,90004) 'Angle   ', casfre(13,nrfran)
 400 #endif
 401 c
 402                 goto 20
 403 c
 404               endif
 405 c
 406 c 2.3.4. ==> Cas du cone defini par 2 centres et 2 rayons
 407 c
 408             elseif ( tyfran.eq.4 ) then
 409 c
 410               if ( mccode(0) .and.
 411      >             mccode( 2) .and. mccode( 3) .and.
 412      >             mccode( 4) .and. mccode( 8) .and.
 413      >             mccode( 9) .and. mccode(10) .and.
 414      >             mccode(11) .and. mccode(12) ) then
 415 #ifdef _DEBUG_HOMARD_
 416                 write (ulsort,texte(langue,6)) messag(langue,tyfran)
 417                 write (ulsort,90004) 'X centre  ', casfre( 2,nrfran)
 418                 write (ulsort,90004) 'Y centre  ', casfre( 3,nrfran)
 419                 write (ulsort,90004) 'Z centre  ', casfre( 4,nrfran)
 420                 write (ulsort,90004) 'Rayon     ', casfre( 8,nrfran)
 421                 write (ulsort,90004) 'X centre 2', casfre( 9,nrfran)
 422                 write (ulsort,90004) 'Y centre 2', casfre(10,nrfran)
 423                 write (ulsort,90004) 'Z centre 2', casfre(11,nrfran)
 424                 write (ulsort,90004) 'Rayon    2', casfre(12,nrfran)
 425 #endif
 426 c
 427                 goto 20
 428 c
 429               endif
 430 c
 431 c 2.3.5. ==> Cas du tore
 432 c
 433             elseif ( tyfran.eq.5 ) then
 434 c
 435               if ( mccode(0) .and.
 436      >             mccode( 2) .and. mccode( 3) .and.
 437      >             mccode( 4) .and.
 438      >             mccode( 5) .and. mccode( 6) .and.
 439      >             mccode( 7) .and.
 440      >             mccode( 8) .and. mccode(12) ) then
 441 #ifdef _DEBUG_HOMARD_
 442                 write (ulsort,texte(langue,6)) messag(langue,tyfran)
 443                 write (ulsort,90004) 'X centre', casfre( 2,nrfran)
 444                 write (ulsort,90004) 'Y centre', casfre( 3,nrfran)
 445                 write (ulsort,90004) 'Z centre', casfre( 4,nrfran)
 446                 write (ulsort,90004) 'X axe   ', casfre( 5,nrfran)
 447                 write (ulsort,90004) 'Y axe   ', casfre( 6,nrfran)
 448                 write (ulsort,90004) 'Z axe   ', casfre( 7,nrfran)
 449                 write (ulsort,90004) 'R revolu', casfre( 8,nrfran)
 450                 write (ulsort,90004) 'R primai', casfre(12,nrfran)
 451 #endif
 452 c
 453                 goto 20
 454 c
 455               endif
 456 c
 457 c 2.3.n. ==> Type inconnu
 458 c
 459             else
 460               write (ulsort,texte(langue,7)) tyfran
 461               codret = 3
 462             endif
 463 c
 464           endif
 465 c
 466           endif
 467 c
 468   200   continue
 469 c
 470 c 2.4. ==> si on arrive ici, c'est qu'il en manque pour la
 471 c          frontiere courante
 472 c
 473         if ( codret.eq.0 ) then
 474 c
 475         write (ulsort,texte(langue,5)) nrfran
 476         write (ulsort,texte(langue,6)) messag(langue,tyfran)
 477         mccod2(1) = .true.
 478         if ( tyfran.eq.1 ) then
 479           do 241 , iaux = 2 , 8
 480             mccod2(iaux) = .true.
 481   241     continue
 482         elseif ( tyfran.eq.2 ) then
 483           do 242 , iaux = 2 , 4
 484             mccod2(iaux) = .true.
 485   242     continue
 486           mccod2(8) = .true.
 487         elseif ( tyfran.eq.3 ) then
 488           do 243 , iaux = 2 , 7
 489             mccod2(iaux) = .true.
 490   243     continue
 491           mccod2(13) = .true.
 492         elseif ( tyfran.eq.4 ) then
 493           do 2441 , iaux = 2 , 4
 494             mccod2(iaux) = .true.
 495  2441     continue
 496           do 2442 , iaux = 8 , 12
 497             mccod2(iaux) = .true.
 498  2442     continue
 499         elseif ( tyfran.eq.5 ) then
 500           do 2451 , iaux = 2 , 8
 501             mccod2(iaux) = .true.
 502  2451     continue
 503           mccod2(12) = .true.
 504         endif
 505 #ifdef _DEBUG_HOMARD_
 506         write(ulsort,99002) 'mccod2', mccod2
 507         write(ulsort,99002) 'mccode', mccode
 508 #endif
 509         do 24 , iaux = 0 , nbmcle
 510           if ( .not.mccode(iaux) .and. mccod2(iaux) ) then
 511             write (ulsort,texte(langue,8)) mclref(iaux)
 512           endif
 513    24   continue
 514 c
 515         codret = 2
 516 c
 517         endif
 518 c
 519    20 continue
 520 c
 521 c====
 522 c 3. la fin
 523 c====
 524 c
 525       if ( codret.ne.0 ) then
 526 c
 527       call dmflsh(iaux)
 528 c
 529 #include "envex2.h"
 530 c
 531       write (ulsort,texte(langue,1)) 'Sortie', nompro
 532       write (ulsort,texte(langue,2)) codret
 533 c
 534       endif
 535 c
 536 #ifdef _DEBUG_HOMARD_
 537       write (ulsort,texte(langue,1)) 'Sortie', nompro
 538       call dmflsh (iaux)
 539 #endif
 540 c
 541       end