src/tool/HOMARD_00/hocmsa.F

   1       subroutine hocmsa ( codret )
   2 c ______________________________________________________________________
   3 c
   4 c                             H O M A R D
   5 c
   6 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   7 c
   8 c Version originale enregistree le 18 juin 1996 sous le numero 96036
   9 c aupres des huissiers de justice Simart et Lavoir a Clamart
  10 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  11 c aupres des huissiers de justice
  12 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  13 c
  14 c    HOMARD est une marque deposee d'Electricite de France
  15 c
  16 c Copyright EDF 1996
  17 c Copyright EDF 1998
  18 c Copyright EDF 2002
  19 c Copyright EDF 2020
  20 c ______________________________________________________________________
  21 c
  22 c   HOMARD : Creation d'un Maillage et d'une Solution Annexe
  23 c   --       -             -                 -        -
  24 c   Option(s) possible(s) : changement de degre
  25 c
  26 c remarque : on n'execute ce programme que si le precedent s'est
  27 c            bien passe
  28 c ______________________________________________________________________
  29 c .        .     .        .                                            .
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . codret . es  .    1   . code de retour des modules                 .
  33 c .        .     .        . en entree = celui du module d'avant        .
  34 c .        .     .        . en sortie = celui du module en cours       .
  35 c .        .     .        . 0 : pas de probleme                        .
  36 c .        .     .        . 1 : manque de temps cpu                    .
  37 c .        .     .        . 2x : probleme dans les memoires            .
  38 c .        .     .        . 3x : probleme dans les fichiers            .
  39 c .        .     .        . 5 : mauvaises options                      .
  40 c .        .     .        . 6 : problemes dans les noms d'objet        .
  41 c ______________________________________________________________________
  42 c
  43 c====
  44 c 0. declarations et dimensionnement
  45 c====
  46 c
  47 c 0.1. ==> generalites
  48 c
  49       implicit none
  50       save
  51 c
  52       character*6 nompro
  53       parameter ( nompro = 'HOCMSA' )
  54 c
  55 #include "motcle.h"
  56 #include "nblang.h"
  57 c
  58 c 0.2. ==> communs
  59 c
  60 #include "envex1.h"
  61 c
  62 #include "gmenti.h"
  63 #include "gmstri.h"
  64 c
  65 #include "cndoad.h"
  66 c
  67 c 0.3. ==> arguments
  68 c
  69       integer codret
  70 c
  71 c 0.4. ==> variables locales
  72 c
  73       integer ulsort, langue, codava
  74       integer adopti, lgopti
  75       integer adopts, lgopts
  76       integer adetco, lgetco
  77       integer nrsect, nrssse
  78       integer nretap, nrsset
  79       integer iaux, jaux
  80       integer codre0
  81       integer codre1, codre2
  82       integer lnomaa
  83 c
  84       character*6 saux
  85       character*8 typobs, nocmaa, nohmap
  86       character*64 nommaa
  87 c
  88       integer nbmess
  89       parameter ( nbmess = 10 )
  90       character*80 texte(nblang,nbmess)
  91 c
  92 c 0.5. ==> initialisations
  93 c ______________________________________________________________________
  94 c
  95 c====
  96 c 1. les initialisations
  97 c====
  98 c
  99       codava = codret
 100 c
 101 c=======================================================================
 102       if ( codava.eq.0 ) then
 103 c=======================================================================
 104 c
 105 #ifdef _DEBUG_HOMARD_
 106       call gmprsx (nompro, nndoad )
 107       call gmprsx (nompro, nndoad//'.OptEnt' )
 108       call gmprsx (nompro, nndoad//'.OptRee' )
 109       call gmprsx (nompro, nndoad//'.OptCar' )
 110       call gmprsx (nompro, nndoad//'.EtatCour' )
 111 #endif
 112 c
 113 c 1.2. ==> le numero d'unite logique de la liste standard
 114 c
 115       call utulls ( ulsort, codret )
 116 c
 117 c 1.3. ==> la langue des messages
 118 c
 119       call gmadoj ( nndoad//'.OptEnt', adopti, lgopti, codret )
 120       if ( codret.eq.0 ) then
 121         langue = imem(adopti)
 122       else
 123         langue = 1
 124         codret = 2
 125       endif
 126 c
 127 #include "impr01.h"
 128 c
 129 #ifdef _DEBUG_HOMARD_
 130       write (ulsort,texte(langue,1)) 'Entree', nompro
 131       call dmflsh (iaux)
 132 #endif
 133 c
 134       if ( imem(adopti+40).eq.1 ) then
 135 c
 136 c 1.4. ==> l'etat courant
 137 c
 138       call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret )
 139 c
 140       if ( codret.eq.0 ) then
 141         if ( imem(adopti+40).eq.1 ) then
 142           nretap = imem(adetco) + 1
 143           imem(adetco) = nretap
 144           nrsset = -1
 145           imem(adetco+1) = nrsset
 146         endif
 147         nrsect = imem(adetco+2) + 10
 148         imem(adetco+2) = nrsect
 149         nrssse = nrsect
 150         imem(adetco+3) = nrssse
 151       else
 152         nretap = -1
 153         nrsset = -1
 154         nrsect = 200
 155         nrssse = nrsect
 156         codret = 2
 157       endif
 158 c
 159 c 1.5. ==> le debut des mesures de temps
 160 c
 161       call gtdems (nrsect)
 162 c
 163 c 1.6. ==> les messages
 164 c
 165       texte(1,4) =
 166      > '(//,a6,'' M A I L L A G E    E T    S O L U T I O N    A N N '',
 167      >''E X E S'')'
 168       texte(1,5) = '(65(''=''),/)'
 169       texte(1,7) = '(''Impossible pour Code_Saturne'')'
 170       texte(1,8) = '(''Le format'',i7,''est impossible.'')'
 171 c
 172       texte(2,4) = '(//,a6,'' A D D I T I O N A L    M E S H    A N D'',
 173      >''    S O L U T I O N'')'
 174       texte(2,5) = '(65(''=''),/)'
 175       texte(2,7) = '(''Impossible for Code_Saturne'')'
 176       texte(2,8) = '(''Format #'',i7,''cannot be written.'')'
 177 c
 178 c 1.7. ==> le titre
 179 c
 180       call utcvne ( nretap, nrsset, saux, iaux, codret )
 181 c
 182       write (ulsort,texte(langue,4)) saux
 183       write (ulsort,texte(langue,5))
 184 c
 185       nrsset = 0
 186       imem(adetco+1) = nrsset
 187 c
 188 c 1.8. ==> les noms d'objets a conserver
 189 c
 190       if ( codret.eq.0 ) then
 191         call gmadoj ( nndoad//'.OptCar', adopts, lgopts, codret )
 192         if ( codret.ne.0 ) then
 193           codret = 2
 194         endif
 195       endif
 196 c
 197 c====
 198 c 2. les structures de base
 199 c====
 200 c
 201 c 2.1. ==> le maillage homard a l'iteration n+1
 202 c
 203       typobs = mchmap
 204       iaux = 0
 205       call utosno ( typobs, nohmap, iaux, ulsort, langue, codre1 )
 206 c
 207 c 2.2. ==> le maillage med annexe
 208 c
 209       if ( imem(adopti+10).eq.6 .or.
 210      >     imem(adopti+10).eq.16 .or.
 211      >     imem(adopti+10).eq.26 .or.
 212      >     imem(adopti+10).eq.36 .or.
 213      >     imem(adopti+10).eq.46 .or.
 214      >     imem(adopti+10).eq.56 ) then
 215 c
 216         typobs = mccnma
 217         iaux = 0
 218         jaux = 1
 219         call utfino ( typobs, iaux, nommaa, lnomaa,
 220      >                jaux,
 221      >                ulsort, langue, codre2 )
 222 c
 223       else
 224 c
 225         lnomaa = 0
 226         codre2 = 0
 227 c
 228       endif
 229 c
 230 c 2.3. ==> bilan
 231 c
 232       codre0 = min ( codre1, codre2 )
 233       codret = max ( abs(codre0), codret,
 234      >               codre1, codre2 )
 235 c
 236 c====
 237 c 3. modification du degre du maillage
 238 c====
 239 c
 240       if ( codret.eq.0 ) then
 241 c
 242       imem(adetco+3) = imem(adetco+3) + 1
 243 c
 244       if ( imem(adopti+40).eq.1 ) then
 245 c
 246 #ifdef _DEBUG_HOMARD_
 247       write (ulsort,texte(langue,3)) 'MMDEGR', nompro
 248 #endif
 249 c
 250         call mmdegr ( lgopti, imem(adopti), lgetco, imem(adetco),
 251      >                nohmap,
 252      >                ulsort, langue, codret )
 253 c
 254       endif
 255 c
 256       endif
 257 c
 258 c====
 259 c 4. conversion du maillage
 260 c====
 261 c
 262 c 4.1. ==> conversion vraie des connectivites
 263 c
 264       if ( codret.eq.0 ) then
 265 c
 266       imem(adetco+3) = imem(adetco+3) + 1
 267 c
 268       nrssse = imem(adetco+3)
 269       call gtdems (nrssse)
 270 c
 271 #ifdef _DEBUG_HOMARD_
 272       write (ulsort,texte(langue,3)) 'PCMACO', nompro
 273       call dmflsh(iaux)
 274 #endif
 275       call pcmaco ( imem(adopti+3),
 276      >              nocmaa, nohmap, nommaa, lnomaa,
 277      >              smem(adopts+19),
 278      >              ulsort, langue, codret )
 279 c
 280       endif
 281 c
 282       if ( codret.eq.0 ) then
 283         smem(adopts+4) = nocmaa
 284       endif
 285 c
 286 c 4.2. ==> les familles
 287 c
 288       if ( codret.eq.0 ) then
 289 c
 290 #ifdef _DEBUG_HOMARD_
 291       write (ulsort,texte(langue,3)) 'PCMAFA', nompro
 292       call dmflsh(iaux)
 293 #endif
 294       call pcmafa ( nocmaa, nohmap,
 295      >              ulsort, langue, codret )
 296 c
 297       endif
 298 c
 299 c 3.2. ==> verification pour le cas extrude
 300 c
 301       if ( codret.eq.0 ) then
 302 c
 303       if ( imem(adopti+38).ne.0 .or.
 304      >     imem(adopti+10).eq.26 .or.
 305      >     imem(adopti+10).eq.36 .or.
 306      >     imem(adopti+10).eq.46 .or.
 307      >     imem(adopti+10).eq.56 ) then
 308 c
 309         write (ulsort,texte(langue,7))
 310         codret = 3
 311 c
 312       endif
 313 c
 314       call gtfims (nrssse)
 315 c
 316       endif
 317 c
 318 c====
 319 c 4. ecriture du maillage
 320 c====
 321 c
 322       if ( codret.eq.0 ) then
 323 c
 324       imem(adetco+3) = imem(adetco+3) + 1
 325 c
 326       if ( imem(adopti+21).eq.1 ) then
 327 c
 328         imem(adopti+49) = 2
 329 c
 330 #ifdef _DEBUG_HOMARD_
 331         write (ulsort,texte(langue,3)) 'HOAPEM', nompro
 332 #endif
 333         call hoapem ( lgopti, imem(adopti), lgopts, smem(adopts),
 334      >                lgetco, imem(adetco),
 335      >                ulsort, langue, codret )
 336 c
 337       endif
 338 c
 339       endif
 340 c
 341 c====
 342 c 5. la fin
 343 c====
 344 c
 345 c 5.1. ==> message si erreur
 346 c
 347       if ( codret.ne.0 ) then
 348 c
 349 #include "envex2.h"
 350 c
 351       write (ulsort,texte(langue,1)) 'Sortie', nompro
 352       write (ulsort,texte(langue,2)) codret
 353 c
 354       endif
 355 c
 356 c 5.2. ==> fin des mesures de temps de la section
 357 c
 358       call gtfims (nrsect)
 359 c
 360       endif
 361 c
 362 #ifdef _DEBUG_HOMARD_
 363       write (ulsort,texte(langue,1)) 'Sortie', nompro
 364       call dmflsh (iaux)
 365 #endif
 366 c
 367 c=======================================================================
 368       endif
 369 c=======================================================================
 370 c
 371       end