src/tool/AP_Conversion/pcmar1.F

   1       subroutine pcmar1 ( narsca,
   2      >                    ntrsca, nqusca,
   3      >                    ntesca, nhesca, npesca, npysca,
   4      >                    nparrc, nptrrc, npqurc,
   5      >                    arerec, trirec, quarec,
   6      >                    tetrec, hexrec, penrec, pyrrec,
   7      >                    ulsort, langue, codret )
   8 c ______________________________________________________________________
   9 c
  10 c                             H O M A R D
  11 c
  12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  13 c
  14 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  15 c aupres des huissiers de justice Simart et Lavoir a Clamart
  16 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  17 c aupres des huissiers de justice
  18 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  19 c
  20 c    HOMARD est une marque deposee d'Electricite de France
  21 c
  22 c Copyright EDF 1996
  23 c Copyright EDF 1998
  24 c Copyright EDF 2002
  25 c Copyright EDF 2020
  26 c ______________________________________________________________________
  27 c
  28 c    aPres adaptation - Conversion de MAillage - Recollements - phase 1
  29 c     -                 -             --         -                    -
  30 c    Passage des listes de recollements des numerotations HOMARD
  31 c    aux numerotations du calcul
  32 c    Mise a jour des renumerotations
  33 c ______________________________________________________________________
  34 c .        .     .        .                                            .
  35 c .  nom   . e/s . taille .           description                      .
  36 c .____________________________________________________________________.
  37 c . narsca . e   . rsarto . numero des aretes du calcul                .
  38 c . ntrsca . e   . rstrto . numero des triangles du calcul             .
  39 c . nqusca . e   . rsquto . numero des quadrangles du calcul           .
  40 c . ntesca . e   . rsteto . numero des tetraedres du calcul            .
  41 c . nhesca . e   . rsheto . numero des hexaedres dans le calcul        .
  42 c . npesca . e   . rspeto . numero des pentaedres dans le calcul       .
  43 c . npysca . e   . rspyto . numero des pyramides dans le calcul sortie .
  44 c . nparrc . e   .   1    . nombre de paires d'aretes a recoller       .
  45 c . nptrrc . e   .   1    . nombre de paires de triangles a recoller   .
  46 c . npqurc . e   .   1    . nombre de paires de quadrangles a recoller .
  47 c . arerec . es  .2*nbarto. paires des aretes a recoller               .
  48 c . trirec . es  .  2* x  . paires des triangles a recoller            .
  49 c . quarec . es  .  2* x  . paires des quadrangles a recoller          .
  50 c . tetrec . es  .  3*x   . paires des tetra. voisins faces a recoller .
  51 c . hexrec . es  .  3*x   . paires des hexa. voisins faces a recoller  .
  52 c . penrec . es  .  3*x   . paires des penta. voisins faces a recoller .
  53 c . pyrrec . es  .  3*x   . paires des pyram. voisines faces a recoller.
  54 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  55 c . langue . e   .    1   . langue des messages                        .
  56 c .        .     .        . 1 : francais, 2 : anglais                  .
  57 c . codret . es  .    1   . code de retour des modules                 .
  58 c .        .     .        . 0 : pas de probleme                        .
  59 c .        .     .        . 1 : probleme                               .
  60 c ______________________________________________________________________
  61 c
  62 c====
  63 c 0. declarations et dimensionnement
  64 c====
  65 c
  66 c 0.1. ==> generalites
  67 c
  68       implicit none
  69       save
  70 c
  71       character*6 nompro
  72       parameter ( nompro = 'PCMAR1' )
  73 c
  74 #include "nblang.h"
  75 c
  76 c 0.2. ==> communs
  77 c
  78 #include "envex1.h"
  79 c
  80 #include "nombsr.h"
  81 #include "nbutil.h"
  82 c
  83 c 0.3. ==> arguments
  84 c
  85       integer narsca(rsarto)
  86       integer ntrsca(rstrto), nqusca(rsquto)
  87       integer ntesca(rsteto), nhesca(rsheto)
  88       integer npysca(rspyto), npesca(rspeto)
  89       integer nparrc, nptrrc, npqurc
  90       integer arerec(2,*), trirec(2,*), quarec(2,*)
  91       integer tetrec(3,*), hexrec(3,*), penrec(3,*), pyrrec(3,*)
  92 c
  93       integer ulsort, langue, codret
  94 c
  95 c 0.4. ==> variables locales
  96 c
  97       integer iaux
  98 c
  99       integer nbmess
 100       parameter ( nbmess = 30 )
 101       character*80 texte(nblang,nbmess)
 102 c
 103 c 0.5. ==> initialisations
 104 c ______________________________________________________________________
 105 c
 106 c====
 107 c 1. messages
 108 c====
 109 c
 110 #include "impr01.h"
 111 c
 112 #ifdef _DEBUG_HOMARD_
 113       write (ulsort,texte(langue,1)) 'Entree', nompro
 114       call dmflsh (iaux)
 115 #endif
 116 c
 117 #include "impr03.h"
 118 c
 119 #ifdef _DEBUG_HOMARD_
 120       write (ulsort,90002) 'nparrc', nparrc
 121       write (ulsort,90002) 'nptrrc', nptrrc
 122       write (ulsort,90002) 'npqurc', npqurc
 123 #endif
 124 c
 125       codret = 0
 126 c
 127 c====
 128 c 2. Changement de numerotation dans les listes d'entites a recoller
 129 c====
 130 c
 131       if ( codret.eq.0 ) then
 132 c
 133 c 2.1. ==> les aretes
 134 c
 135         do 21 , iaux = 1 , nparrc
 136 c
 137           arerec(1,iaux) = narsca(arerec(1,iaux))
 138           arerec(2,iaux) = narsca(arerec(2,iaux))
 139 c
 140    21   continue
 141 c
 142 c 2.2. ==> les triangles
 143 c
 144         do 22 , iaux = 1 , nptrrc
 145 c
 146           trirec(1,iaux) = ntrsca(trirec(1,iaux))
 147           trirec(2,iaux) = ntrsca(trirec(2,iaux))
 148 c
 149    22   continue
 150 c
 151 c 2.3. ==> les quadrangles
 152 c
 153         do 23 , iaux = 1 , npqurc
 154 c
 155           quarec(1,iaux) = nqusca(quarec(1,iaux))
 156           quarec(2,iaux) = nqusca(quarec(2,iaux))
 157 c
 158    23   continue
 159 c
 160 c 2.4. ==> les tetraedres
 161 c
 162         do 24 , iaux = 1 , nptrrc
 163 c
 164           tetrec(1,iaux) = ntesca(tetrec(1,iaux))
 165           tetrec(2,iaux) = ntesca(tetrec(2,iaux))
 166           tetrec(3,iaux) = ntrsca(tetrec(3,iaux))
 167 c
 168    24   continue
 169 c
 170 c 2.5. ==> les hexaedres
 171 c
 172         do 25 , iaux = 1 , npqurc
 173 c
 174           hexrec(1,iaux) = nhesca(hexrec(1,iaux))
 175           hexrec(2,iaux) = nhesca(hexrec(2,iaux))
 176           hexrec(3,iaux) = nqusca(hexrec(3,iaux))
 177 c
 178    25   continue
 179 c
 180 c 2.6. ==> les pentaedres
 181 c
 182         if ( rspeto.gt.0 ) then
 183 c
 184           do 26 , iaux = 1 , nptrrc+npqurc
 185 c
 186             penrec(1,iaux) = npesca(penrec(1,iaux))
 187             penrec(2,iaux) = npesca(penrec(2,iaux))
 188 c
 189    26     continue
 190 c
 191         endif
 192 c
 193 c 2.7. ==> les pyramides
 194 c
 195         if ( rspyto.gt.0 ) then
 196 c
 197           do 27 , iaux = 1 , nptrrc+npqurc
 198 c
 199             pyrrec(1,iaux) = npysca(pyrrec(1,iaux))
 200             pyrrec(2,iaux) = npysca(pyrrec(2,iaux))
 201 c
 202    27     continue
 203 c
 204         endif
 205 c
 206       endif
 207 c
 208 c====
 209 c 3. la fin
 210 c====
 211 c
 212       if ( codret.ne.0 ) then
 213 c
 214 #include "envex2.h"
 215 c
 216       write (ulsort,texte(langue,1)) 'Sortie', nompro
 217       write (ulsort,texte(langue,2)) codret
 218 c
 219       endif
 220 c
 221 #ifdef _DEBUG_HOMARD_
 222       write (ulsort,texte(langue,1)) 'Sortie', nompro
 223       call dmflsh (iaux)
 224 #endif
 225 c
 226       end