src/tool/Decision/deard0.F

   1       subroutine deard0 ( nomail, ntrav1, ntrav2, ntrav3,
   2      >                    phetar, psomar, pfilar, pmerar,
   3      >                    phettr, paretr, pfiltr, ppertr, pnivtr,
   4      >                    phetqu, parequ, pfilqu, pperqu, pnivqu,
   5      >                    phette, ptrite,
   6      >                    phethe, pquahe, pcoquh,
   7      >                    phetpy, pfacpy, pcofay,
   8      >                    phetpe, pfacpe, pcofap,
   9      >                    pposif, pfacar,
  10      >                    advotr, advoqu, adpptr, adppqu,
  11      >                    pdecfa, pdecar,
  12      >                    adhoar, adhotr, adhoqu,
  13      >                    ptrav3,
  14      >                    ulsort, langue, codret )
  15 c ______________________________________________________________________
  16 c
  17 c                             H O M A R D
  18 c
  19 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  20 c
  21 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  22 c aupres des huissiers de justice Simart et Lavoir a Clamart
  23 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  24 c aupres des huissiers de justice
  25 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  26 c
  27 c    HOMARD est une marque deposee d'Electricite de France
  28 c
  29 c Copyright EDF 1996
  30 c Copyright EDF 1998
  31 c Copyright EDF 2002
  32 c Copyright EDF 2020
  33 c ______________________________________________________________________
  34 c
  35 c traitement des DEcisions - Adresses pour le Raffinement
  36 c                --          -                -
  37 c                            et le Deraffinement - phase 0
  38 c                                  -                     -
  39 c ______________________________________________________________________
  40 c .        .     .        .                                            .
  41 c .  nom   . e/s . taille .           description                      .
  42 c .____________________________________________________________________.
  43 c . nomail . e   .  ch8   . nom de l'objet contenant le maillage       .
  44 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  45 c . langue . e   .    1   . langue des messages                        .
  46 c .        .     .        . 1 : francais, 2 : anglais                  .
  47 c . codret . es  .    1   . code de retour des modules                 .
  48 c .        .     .        . 0 : pas de probleme                        .
  49 c .        .     .        . 5 : mauvais type de code de calcul associe .
  50 c ______________________________________________________________________
  51 c
  52 c====
  53 c 0. declarations et dimensionnement
  54 c====
  55 c
  56 c 0.1. ==> generalites
  57 c
  58       implicit none
  59       save
  60 c
  61       character*6 nompro
  62       parameter ( nompro = 'DEARD0' )
  63 c
  64 #include "nblang.h"
  65 c
  66 c 0.2. ==> communs
  67 c
  68 #include "envex1.h"
  69 c
  70 #include "nombtr.h"
  71 #include "nombqu.h"
  72 #include "nombte.h"
  73 #include "nombhe.h"
  74 #include "nombpy.h"
  75 #include "nombpe.h"
  76 c
  77 c 0.3. ==> arguments
  78 c
  79       character*8 nomail, ntrav1, ntrav2, ntrav3
  80 c
  81       integer phetar, psomar, pfilar, pmerar
  82       integer phettr, paretr, pfiltr, ppertr, pnivtr
  83       integer phetqu, parequ, pfilqu, pperqu, pnivqu
  84       integer phette, ptrite
  85       integer phethe, pquahe, pcoquh
  86       integer phetpy, pfacpy, pcofay
  87       integer phetpe, pfacpe, pcofap
  88       integer pposif, pfacar
  89       integer advotr, advoqu, adpptr, adppqu
  90       integer pdecfa, pdecar
  91       integer adhoar, adhotr, adhoqu
  92       integer ptrav3
  93 c
  94       integer ulsort, langue, codret
  95 c
  96 c 0.4. ==> variables locales
  97 c
  98       integer iaux, jaux
  99 c
 100       integer codre0
 101       integer codre1, codre2
 102 c
 103       integer adnmtr
 104       integer adnmqu
 105 c
 106       character*8 nharet, nhtria, nhquad
 107       character*8 nhvois
 108 c
 109       integer nbmess
 110       parameter ( nbmess = 10 )
 111       character*80 texte(nblang,nbmess)
 112 c
 113 c 0.5. ==> initialisations
 114 c ______________________________________________________________________
 115 c
 116 c====
 117 c 1. messages
 118 c====
 119 c
 120 #include "impr01.h"
 121 c
 122 #ifdef _DEBUG_HOMARD_
 123       write (ulsort,texte(langue,1)) 'Entree', nompro
 124       call dmflsh (iaux)
 125 #endif
 126 c
 127 c====
 128 c 2. structure generale
 129 c====
 130 c
 131 #ifdef _DEBUG_HOMARD_
 132       write (ulsort,texte(langue,3)) 'UTAD99', nompro
 133 #endif
 134       call utad99 ( nomail,
 135      >              phetar, psomar, pfilar, pmerar, adhoar,
 136      >              phettr, paretr, pfiltr, ppertr, pnivtr,
 137      >              adnmtr, adhotr,
 138      >              phetqu, parequ, pfilqu, pperqu, pnivqu,
 139      >              adnmqu, adhoqu,
 140      >              phette, ptrite,
 141      >              phethe, pquahe, pcoquh,
 142      >              phetpy, pfacpy, pcofay,
 143      >              phetpe, pfacpe, pcofap,
 144      >              nhvois, nharet, nhtria, nhquad,
 145      >              ulsort, langue, codret )
 146 c
 147 c====
 148 c 3. les voisinages
 149 c====
 150 #ifdef _DEBUG_HOMARD_
 151       write (ulsort,*) '3. les voisinages ; codret = ', codret
 152 #endif
 153 c
 154       if ( codret.eq.0 ) then
 155 c
 156       iaux = 3
 157       if ( nbteto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then
 158         iaux = iaux*5
 159       endif
 160       if ( nbheto.ne.0 .or. nbpyto.ne.0 .or. nbpeto.ne.0 ) then
 161         iaux = iaux*7
 162       endif
 163       if ( nbpyto.ne.0 .or. nbpeto.ne.0 ) then
 164         iaux = iaux*13*17
 165       endif
 166 #ifdef _DEBUG_HOMARD_
 167       write (ulsort,texte(langue,3)) 'UTAD04', nompro
 168 #endif
 169       call utad04 ( iaux, nhvois,
 170      >                jaux,   jaux, pposif, pfacar,
 171      >              advotr, advoqu,
 172      >                jaux,   jaux, adpptr, adppqu,
 173      >                jaux,   jaux,   jaux,
 174      >                jaux,   jaux,   jaux,
 175      >                jaux,   jaux,   jaux,
 176      >                jaux,   jaux,   jaux,
 177      >              ulsort, langue, codret )
 178 c
 179       endif
 180 c
 181 c====
 182 c 4. les decisions et les homologues
 183 c====
 184 #ifdef _DEBUG_HOMARD_
 185       write (ulsort,*) '4. decisions/homologues ; codret = ', codret
 186 #endif
 187 c
 188       if ( codret.eq.0 ) then
 189 c
 190       call gmadoj ( ntrav1, pdecar, iaux, codre1 )
 191       call gmadoj ( ntrav2, pdecfa, iaux, codre2 )
 192 c
 193       codre0 = min ( codre1, codre2 )
 194       codret = max ( abs(codre0), codret,
 195      >               codre1, codre2 )
 196 c
 197       endif
 198 c
 199 c====
 200 c 5. allocations supplementaires
 201 c====
 202 #ifdef _DEBUG_HOMARD_
 203       write (ulsort,*) '5. alloc supplementaires ; codret = ', codret
 204 #endif
 205 c
 206       if ( codret.eq.0 ) then
 207 c
 208       iaux = nbtrac + nbquac
 209       call gmalot ( ntrav3, 'entier  ', iaux, ptrav3, codret )
 210 c
 211       endif
 212 c
 213 c====
 214 c 6. la fin
 215 c====
 216 c
 217       if ( codret.ne.0 ) then
 218 c
 219 #include "envex2.h"
 220 c
 221       write (ulsort,texte(langue,1)) 'Sortie', nompro
 222       write (ulsort,texte(langue,2)) codret
 223 c
 224       endif
 225 c
 226 #ifdef _DEBUG_HOMARD_
 227       write (ulsort,texte(langue,1)) 'Sortie', nompro
 228       call dmflsh (iaux)
 229 #endif
 230 c
 231       end