src/tool/ES_MED/esemmd.F

   1       subroutine esemmd ( nocmai, mcfima, mcnoma, typouv,
   2      >                    ulsort, langue, codret )
   3 c ______________________________________________________________________
   4 c
   5 c                             H O M A R D
   6 c
   7 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   8 c
   9 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  10 c aupres des huissiers de justice Simart et Lavoir a Clamart
  11 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  12 c aupres des huissiers de justice
  13 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  14 c
  15 c    HOMARD est une marque deposee d'Electricite de France
  16 c
  17 c Copyright EDF 1996
  18 c Copyright EDF 1998
  19 c Copyright EDF 2002
  20 c Copyright EDF 2020
  21 c ______________________________________________________________________
  22 c
  23 c  Entree-Sortie - Ecriture d'un Maillage au format MeD
  24 c  -      -        -             -                  - -
  25 c ______________________________________________________________________
  26 c .        .     .        .                                            .
  27 c .  nom   . e/s . taille .           description                      .
  28 c .____________________________________________________________________.
  29 c . nocmai . e   . char*8 . nom de l'objet maillage calcul             .
  30 c . mcfima . e   . char*8 . mot-cle pour le fichier du maillage        .
  31 c . mcnoma . e   . char*8 . mot-cle du nom du maillage dans le fichier .
  32 c . typouv . e   .   1    . type d'ouverture du fichier a ecrire       .
  33 c .        .     .        . 0 : ecrasement                             .
  34 c .        .     .        . 1 : enrichissement                         .
  35 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  36 c . langue . e   .    1   . langue des messages                        .
  37 c .        .     .        . 1 : francais, 2 : anglais                  .
  38 c . codret . es  .    1   . code de retour des modules                 .
  39 c .        .     .        . en entree = celui du module d'avant        .
  40 c .        .     .        . en sortie = celui du module en cours       .
  41 c .        .     .        . 0 : pas de probleme                        .
  42 c .        .     .        . 2x : probleme dans les memoires            .
  43 c .        .     .        . 3x : probleme dans les fichiers            .
  44 c .        .     .        . -10 : fichier inconnu                      .
  45 c .        .     .        . -20 : nom de maillage inconnu              .
  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 = 'ESEMMD' )
  59 c
  60 #include "nblang.h"
  61 #include "consts.h"
  62 c
  63 c 0.2. ==> communs
  64 c
  65 #include "envex1.h"
  66 c
  67 #include "gmenti.h"
  68 #include "gmreel.h"
  69 #include "gmstri.h"
  70 c
  71 #include "nbutil.h"
  72 #include "envca1.h"
  73 c
  74 c 0.3. ==> arguments
  75 c
  76       integer typouv
  77 c
  78       character*8 nocmai, mcfima, mcnoma
  79 c
  80       integer ulsort, langue, codret
  81 c
  82 c 0.4. ==> variables locales
  83 c
  84 #include "meddc0.h"
  85 c
  86       integer iaux, jaux
  87       integer adnomb
  88       integer pfamen, pcoonc, pfamee, pnoeel, ptypel
  89       integer pgrpo, pgrtab
  90       integer pnumfa, pnomfa
  91       integer nbpqt
  92       integer pinftb
  93       integer adeqpo, adeqin
  94       integer adeqno, adeqar, adeqtr, adeqqu
  95       integer adeqte, adeqhe
  96       integer ptrav1, ptrav2
  97 c
  98       integer codre1, codre2, codre3, codre4, codre5
  99       integer codre6
 100       integer codre0
 101 c
 102       integer*8 idfmed
 103       integer lnomfi, lnomam
 104       integer nbnomb
 105       integer nbnoto
 106 c
 107       character*8 typobs
 108       character*8 ntrav1, ntrav2
 109       character*8 ncinfo, ncnoeu, nccono, nccode
 110       character*8 nccoex, ncfami
 111       character*8 ncequi, ncfron, ncnomb
 112       character*64 nomamd
 113       character*200 nomfic
 114 c
 115       integer nbmess
 116       parameter ( nbmess = 150 )
 117       character*80 texte(nblang,nbmess)
 118 c
 119 c 0.5. ==> initialisations
 120 c ______________________________________________________________________
 121 c
 122 c====
 123 c 1. initialisations
 124 c====
 125 c
 126 #include "impr01.h"
 127 c
 128 #ifdef _DEBUG_HOMARD_
 129       write (ulsort,texte(langue,1)) 'Entree', nompro
 130       call dmflsh (iaux)
 131 #endif
 132 c
 133 #include "impr03.h"
 134 c
 135 #include "esimpr.h"
 136 c
 137 c====
 138 c 2. premiers decodages
 139 c====
 140 c
 141 c 2.1. ==> nom du fichier contenant le maillage
 142 c
 143       typobs = mcfima
 144       iaux = 0
 145       jaux = 1
 146       call utfino ( typobs, iaux, nomfic, lnomfi,
 147      >              jaux,
 148      >              ulsort, langue, codret )
 149       if ( codret.ne.0 ) then
 150         write (ulsort,texte(langue,8)) 'en sortie'
 151         codret = -10
 152       endif
 153 c
 154 c 2.2. ==> nom du maillage dans le fichier
 155 c
 156       if ( codret.eq.0 ) then
 157       typobs = mcnoma
 158       iaux = 0
 159       jaux = 0
 160       call utfino ( typobs, iaux, nomamd, lnomam,
 161      >              jaux,
 162      >              ulsort, langue, codret )
 163       if ( codret.ne.0 ) then
 164         call utosme ( typobs, ulsort, langue )
 165         if ( codret.eq.4 ) then
 166           write (ulsort,texte(langue,52)) lnomam
 167           write (ulsort,texte(langue,53)) len(nomamd)
 168         endif
 169         codret = -20
 170       endif
 171       endif
 172 c
 173 c====
 174 c 3. ouverture en mode d'ecrasement ou d'enrichissement
 175 c====
 176 #ifdef _DEBUG_HOMARD_
 177       write (ulsort,90002) '3. ouverture ; codret', codret
 178 #endif
 179 c
 180       if ( codret.eq.0 ) then
 181 c
 182       if ( typouv.eq.0 ) then
 183         iaux = edcrea
 184       else
 185         iaux = edrdwr
 186       endif
 187 #ifdef _DEBUG_HOMARD_
 188       write (ulsort,texte(langue,3)) 'MFIOPE', nompro
 189 #endif
 190       call mfiope ( idfmed, nomfic(1:lnomfi), iaux, codret )
 191       if ( codret.ne.0 ) then
 192         write (ulsort,texte(langue,9))
 193       endif
 194       endif
 195 c
 196 c====
 197 c 4. recuperation des donnees du maillage de calcul
 198 c====
 199 #ifdef _DEBUG_HOMARD_
 200       write (ulsort,90002) '4. recuperation ; codret', codret
 201 #endif
 202 c
 203 c 4.1. ==> l'objet de tete
 204 c
 205       if ( codret.eq.0 ) then
 206 c
 207 #ifdef _DEBUG_HOMARD_
 208       call gmprsx (nompro, nocmai )
 209 #endif
 210 c
 211 #ifdef _DEBUG_HOMARD_
 212       write (ulsort,texte(langue,3)) 'UTNOMC', nompro
 213 #endif
 214       call utnomc ( nocmai,
 215      >              sdimca, mdimca,
 216      >               degre, mailet, maconf, homolo, hierar,
 217      >              nbnomb,
 218      >              ncinfo, ncnoeu, nccono, nccode,
 219      >              nccoex, ncfami,
 220      >              ncequi, ncfron, ncnomb,
 221      >              ulsort, langue, codret)
 222 c
 223 #ifdef _DEBUG_HOMARD_
 224       write (ulsort,90002) 'sdimca', sdimca
 225       write (ulsort,90002) 'mdimca', mdimca
 226       call gmprsx (nompro, ncnoeu )
 227       call gmprsx (nompro, nccono )
 228       call gmprsx (nompro, ncfami )
 229       call gmprsx (nompro,ncfami//'.Nom')
 230       call gmprsx (nompro,ncfami//'.Groupe')
 231 #endif
 232 c
 233       endif
 234 c
 235 c 4.2. ==> objets lies au maillage de calcul
 236 c
 237 c 4.2.1. ==> les informations generales
 238 c
 239       if ( codret.eq.0 ) then
 240 c
 241       call gmadoj ( ncinfo//'.Table'   , pinftb, iaux, codre0 )
 242       call gmliat ( ncinfo, 1, iaux, codre2 )
 243       nbpqt = iaux - 1
 244 c
 245       codre0 = min ( codre1, codre2 )
 246       codret = max ( abs(codre0), codret,
 247      >               codre1, codre2 )
 248 c
 249       endif
 250 c
 251 c 4.2.2. ==> les nombres
 252 c
 253       if ( codret.eq.0 ) then
 254 c
 255       call gmadoj ( ncnomb, adnomb, iaux, codret )
 256 c
 257       endif
 258 c
 259       if ( codret.eq.0 ) then
 260 c
 261 #ifdef _DEBUG_HOMARD_
 262       write (ulsort,texte(langue,3)) 'UTNBMC', nompro
 263 #endif
 264       call utnbmc ( imem(adnomb),
 265      >              nbmaae, nbmafe, nbmnei,
 266      >              numano, numael,
 267      >              nbma2d, nbma3d,
 268      >              nbmapo, nbsegm, nbtria, nbtetr,
 269      >              nbquad, nbhexa, nbpent, nbpyra,
 270      >              nbfmed, nbfmen, ngrouc,
 271      >              nbequi,
 272      >              nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu,
 273      >              ulsort, langue, codret )
 274 c
 275       endif
 276 c
 277 c 4.2.3. ==> les nombres
 278 c
 279       if ( codret.eq.0 ) then
 280 c
 281       call gmliat ( ncnoeu, 1, nbnoto, codre1 )
 282       call gmliat ( nccono, 1, nbelem, codre2 )
 283       call gmliat ( nccono, 2, nbmane, codre3 )
 284 c
 285       codre0 = min ( codre1, codre2, codre3 )
 286       codret = max ( abs(codre0), codret,
 287      >               codre1, codre2, codre3 )
 288 c
 289 c 4.2.4. ==> les adresses
 290 c
 291 #ifdef _DEBUG_HOMARD_
 292       write (ulsort,texte(langue,3)) 'UTAD11', nompro
 293 #endif
 294       iaux = 6006
 295       call utad11 ( iaux, ncnoeu, nccono,
 296      >              pcoonc, pfamen,   jaux,  jaux,
 297      >              ptypel, pfamee, pnoeel,  jaux,
 298      >              ulsort, langue, codret )
 299 c
 300 c 4.2.5. ==> les familles
 301 c
 302       pnumfa = 1
 303       pnomfa = 1
 304       pgrpo = 1
 305       pgrtab = 1
 306 c
 307       if ( nbfmed.ne.0 ) then
 308 c
 309 #ifdef _DEBUG_HOMARD_
 310         write (ulsort,texte(langue,3)) 'UTAD13', nompro
 311 #endif
 312         iaux = 6
 313         if ( ngrouc.gt.0 ) then
 314           iaux = iaux*5
 315         endif
 316         call utad13 ( iaux, ncfami,
 317      >                pnumfa, pnomfa,
 318      >                pgrpo,   jaux, pgrtab,
 319      >                ulsort, langue, codret )
 320 c
 321       endif
 322 cgn        call gmprsx (nompro, ncfami//'.Groupe')
 323 cgn        call gmprsx (nompro, ncfami//'.Groupe.Pointeur')
 324 cgn        call gmprsx (nompro, ncfami//'.Groupe.Taille')
 325 cgn        call gmprsx (nompro, ncfami//'.Groupe.Table')
 326 c
 327 c 4.2.6. ==> les equivalences
 328 c
 329       if ( nbequi.ne.0 ) then
 330 c
 331       call gmadoj ( ncequi//'.Pointeur', adeqpo, iaux, codre1 )
 332       call gmadoj ( ncequi//'.InfoGene', adeqin, iaux, codre2 )
 333 c
 334       codre0 = min ( codre1, codre2 )
 335       codret = max ( abs(codre0), codret,
 336      >               codre1, codre2 )
 337 c
 338       call gmadoj ( ncequi//'.Noeud', adeqno, iaux, codre1 )
 339       call gmadoj ( ncequi//'.Arete', adeqar, iaux, codre2 )
 340       call gmadoj ( ncequi//'.Trian', adeqtr, iaux, codre3 )
 341       call gmadoj ( ncequi//'.Quadr', adeqqu, iaux, codre4 )
 342       call gmadoj ( ncequi//'.Tetra', adeqte, iaux, codre5 )
 343       call gmadoj ( ncequi//'.Hexae', adeqhe, iaux, codre6 )
 344 c
 345       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 346      >               codre6 )
 347       codret = max ( abs(codre0), codret,
 348      >               codre1, codre2, codre3, codre4, codre5,
 349      >               codre6 )
 350 c
 351       endif
 352 c
 353 c 4.2.7. ==> la frontiere
 354 c
 355       endif
 356 c
 357 c 4.3. ==> tableaux de travail
 358 c
 359       if ( codret.eq.0 ) then
 360 c
 361       iaux = nbelem*(nbmane+1)+nbsegm+nbtria
 362       call gmalot ( ntrav1, 'entier  ', iaux   , ptrav1, codre1 )
 363       call gmalot ( ntrav2, 'entier  ', nbelem , ptrav2, codre2 )
 364 c
 365       codre0 = min ( codre1, codre2 )
 366       codret = max ( abs(codre0), codret,
 367      >               codre1, codre2 )
 368       endif
 369 c
 370 c===
 371 c 5. ecriture proprement dite
 372 c===
 373 #ifdef _DEBUG_HOMARD_
 374       write (ulsort,90002) '5. ecriture ; codret', codret
 375 #endif
 376 c
 377       if ( codret.eq.0 ) then
 378 c
 379 #ifdef _DEBUG_HOMARD_
 380       write (ulsort,texte(langue,3)) 'ESEMM1', nompro
 381 #endif
 382       call esemm1 ( idfmed, nomamd, lnomam,
 383      >         nbnoto,
 384      >         rmem(pcoonc), imem(pfamen), imem(pnoeel),
 385      >         imem(pfamee), imem(ptypel),
 386      >         imem(pnumfa), smem(pnomfa),
 387      >         imem(pgrpo), smem(pgrtab),
 388      >          nbpqt, smem(pinftb),
 389      >         imem(adeqpo), smem(adeqin),
 390      >         imem(adeqno),
 391      >         imem(adeqar), imem(adeqtr), imem(adeqqu),
 392      >         imem(adeqte), imem(adeqhe),
 393      >         imem(ptrav1), imem(ptrav2),
 394      >         ulsort, langue, codret )
 395 c
 396       endif
 397 c
 398 c===
 399 c 6. nettoyage
 400 c===
 401 c
 402       if ( codret.eq.0 ) then
 403 c
 404       call gmlboj ( ntrav1 , codre1 )
 405       call gmlboj ( ntrav2 , codre2 )
 406 c
 407       codre0 = min ( codre1, codre2 )
 408       codret = max ( abs(codre0), codret,
 409      >               codre1, codre2 )
 410 c
 411       endif
 412 c
 413 c===
 414 c 7. fermeture du fichier
 415 c===
 416 c
 417       if ( codret.eq.0 ) then
 418 c
 419 #ifdef _DEBUG_HOMARD_
 420       write (ulsort,texte(langue,3)) 'MFICLO', nompro
 421 #endif
 422       call mficlo ( idfmed, codret )
 423       if ( codret.ne.0 ) then
 424         write (ulsort,texte(langue,10))
 425       endif
 426 c
 427       endif
 428 c
 429 c====
 430 c 8. la fin
 431 c====
 432 c
 433       if ( codret.ne.0 ) then
 434 c
 435 #include "envex2.h"
 436 c
 437       write (ulsort,texte(langue,1)) 'Sortie', nompro
 438       write (ulsort,texte(langue,2)) codret
 439       if ( codret.ne.-10 ) then
 440         write (ulsort,texte(langue,8)) nomfic
 441         if ( codret.ne.-20 ) then
 442           write (ulsort,texte(langue,22)) nomamd
 443         endif
 444       endif
 445 c
 446       endif
 447 c
 448 #ifdef _DEBUG_HOMARD_
 449       write (ulsort,texte(langue,1)) 'Sortie', nompro
 450       call dmflsh (iaux)
 451 #endif
 452 c
 453       end