src/tool/AP_Conversion/pccac1.F

   1       subroutine pccac1 ( nbcham, nocham,
   2      >                    nnfonc, npfonc, obprof, oblopg,
   3      >                    ulsort, langue, codret )
   4 c ______________________________________________________________________
   5 c
   6 c                             H O M A R D
   7 c
   8 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   9 c
  10 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  11 c aupres des huissiers de justice Simart et Lavoir a Clamart
  12 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  13 c aupres des huissiers de justice
  14 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  15 c
  16 c    HOMARD est une marque deposee d'Electricite de France
  17 c
  18 c Copyright EDF 1996
  19 c Copyright EDF 1998
  20 c Copyright EDF 2002
  21 c Copyright EDF 2020
  22 c ______________________________________________________________________
  23 c
  24 c    aPres adaptation - mise a jour des CAracteristiques des Champs - 1
  25 c     -                                 --                   -        -
  26 c ______________________________________________________________________
  27 c .        .     .        .                                            .
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . nbcham . e   .   1    . nombre de champs                           .
  31 c . nocham . es  . nbcham . nom des objets qui contiennent la          .
  32 c .        .     .        . description de chaque champ                .
  33 c . nnfonc . e   . char8  . nom de la fonction iteration n             .
  34 c . npfonc . e   . char8  . nom de la fonction iteration n+1           .
  35 c . obprof . e   . char8  . nom de l'objet profil eventuel             .
  36 c . oblopg . e   . char8  . nom de l'objet localisation eventuelle     .
  37 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  38 c . langue . e   .    1   . langue des messages                        .
  39 c .        .     .        . 1 : francais, 2 : anglais                  .
  40 c . codret . es  .    1   . code de retour des modules                 .
  41 c .        .     .        . 0 : pas de probleme                        .
  42 c .        .     .        . 1 : probleme                               .
  43 c ______________________________________________________________________
  44 c
  45 c====
  46 c 0. declarations et dimensionnement
  47 c====
  48 c
  49 c 0.1. ==> generalites
  50 c
  51       implicit none
  52       save
  53 c
  54       character*6 nompro
  55       parameter ( nompro = 'PCCAC1' )
  56 c
  57 #include "nblang.h"
  58 #include "consts.h"
  59 #include "meddc0.h"
  60 c
  61 c 0.2. ==> communs
  62 c
  63 #include "envex1.h"
  64 c
  65 #include "esutil.h"
  66 #include "gmenti.h"
  67 #include "gmstri.h"
  68 c
  69 c 0.3. ==> arguments
  70 c
  71       integer nbcham
  72 c
  73       character*8 nocham(nbcham)
  74       character*8 npfonc, nnfonc, obprof, oblopg
  75 c
  76       integer ulsort, langue, codret
  77 c
  78 c 0.4. ==> variables locales
  79 c
  80       integer iaux, jaux, kaux
  81       integer codre1, codre2, codre3
  82       integer codre0
  83 c
  84       integer nrocha, nrotv
  85       integer nbtvch
  86       integer adcaen, adcaca
  87       integer typgeo, ngauss, nbenmx, nbvapr, nbtyas
  88       integer carsup, nbtafo, typint
  89       integer advale, advalr, adobch, adprpg, adtyas
  90 c
  91       integer nbmess
  92       parameter ( nbmess = 10 )
  93       character*80 texte(nblang,nbmess)
  94 c
  95 c 0.5. ==> initialisations
  96 c ______________________________________________________________________
  97 c
  98 c====
  99 c 1. initialisations
 100 c====
 101 c
 102 c 1.1. ==> messages
 103 c
 104 #include "impr01.h"
 105 c
 106 #ifdef _DEBUG_HOMARD_
 107       write (ulsort,texte(langue,1)) 'Entree', nompro
 108       call dmflsh (iaux)
 109 #endif
 110 c
 111       texte(1,4) = '(''Etape '',a1,'' : nom de la fonction = '',a8)'
 112       texte(1,5) = '(''... Le remplacement de la fonction a eu lieu.'')'
 113 c
 114       texte(2,4) = '(''Stage '',a1,'' : name of the function = '',a8)'
 115       texte(2,5) = '(''... Change of function occured.'')'
 116 c
 117 #ifdef _DEBUG_HOMARD_
 118       write (ulsort,texte(langue,4)) 'n', nnfonc
 119       write (ulsort,texte(langue,4)) 'p' ,npfonc
 120 #endif
 121 c
 122 c====
 123 c 2. on passe en revue tous les champs
 124 c====
 125 c
 126       do 20 , nrocha = 1 , nbcham
 127 c
 128 #ifdef _DEBUG_HOMARD_
 129       write (ulsort,*) '.. Nom du champ = ',nocham(nrocha)
 130       call gmprsx (nompro, nocham(nrocha)//'.Cham_Car' )
 131 #endif
 132 c
 133 c 2.1. ==> reperage des noms des fonctions
 134 c
 135       if ( codret.eq.0 ) then
 136 c
 137       call gmliat ( nocham(nrocha), 2, nbtvch, codre1 )
 138       call gmadoj ( nocham(nrocha)//'.Cham_Ent', adcaen, iaux, codre2 )
 139       call gmadoj ( nocham(nrocha)//'.Cham_Car', adcaca, iaux, codre3 )
 140 c
 141       codre0 = min ( codre1, codre2, codre3 )
 142       codret = max ( abs(codre0), codret,
 143      >               codre1, codre2, codre3 )
 144 c
 145       endif
 146 c
 147 c 2.2. ==> on parcourt les tableaux
 148 c          on opere un traitement quand on tombe sur la bonne fonction
 149 c
 150       if ( codret.eq.0 ) then
 151 c
 152       do 21 , nrotv = 1, nbtvch
 153 c
 154         jaux = adcaca + nbincc*(nrotv-1)
 155 c
 156         if ( smem(jaux).eq.nnfonc ) then
 157 c
 158 c 2.2.1. ==> on met a jour le nombre de valeurs
 159 c
 160           if ( codret.eq.0 ) then
 161 c
 162 #ifdef _DEBUG_HOMARD_
 163       write (ulsort,texte(langue,3)) 'UTCAFO', nompro
 164 #endif
 165           call utcafo ( npfonc,
 166      >                  iaux,
 167      >                  typgeo, ngauss, nbenmx, nbvapr, nbtyas,
 168      >                  carsup, nbtafo, typint,
 169      >                  advale, advalr, adobch, adprpg, adtyas,
 170      >                  ulsort, langue, codret )
 171 c
 172           endif
 173 c
 174           if ( codret.eq.0 ) then
 175 c          Rappel :
 176 c       1. type de support au sens MED
 177 c       2. numero du pas de temps
 178 c       4. 1, si numero d'ordre, 0 sinon
 179 c       3. numero d'ordre
 180 c       4. nombre de points de Gauss
 181 c       5. nombre d'entites support
 182 c       6. nombre de valeurs du profil eventuel
 183 c       7. nombre de supports associes
 184 c       8. noeuds par elements/points de Gauss/autre
 185 c       9. numero du 1er tableau dans la fonction
 186 c       10. -1 ou champ elga/champ elno
 187 c       11. type interpolation
 188 c       21-nbinec. type des supports associes
 189 c
 190           jaux = adcaen + nbinec*(nrotv-1)
 191           imem(jaux+4) = nbenmx
 192           imem(jaux+5) = nbvapr
 193           imem(jaux+6) = nbtyas
 194 cgn              print *,nbtyas
 195 cgn              print *,(imem(adtyas+kaux-1),kaux = 1 , nbtyas)
 196           do 211 , kaux = 1 , nbtyas
 197             imem(jaux+19+kaux) = imem(adtyas+kaux-1)
 198   211     continue
 199 c
 200           endif
 201 c
 202 c 2.2.2. ==> on remplace l'ancien nom de la fonction par le nouveau
 203 c
 204           jaux = adcaca + nbincc*(nrotv-1)
 205           smem(jaux) = npfonc
 206 #ifdef _DEBUG_HOMARD_
 207           write (ulsort,texte(langue,5))
 208 #endif
 209 c
 210 c 2.2.3. ==> on archive le nom de l'eventuel profil
 211 c
 212           if ( nbvapr.gt.0 ) then
 213             smem(jaux+1) = obprof
 214           else
 215             smem(jaux+1) = blan08
 216           endif
 217 c
 218 c 2.2.4. ==> on archive le nom de l'eventuelle localisation
 219 c
 220           smem(jaux+2) = oblopg
 221 c
 222         endif
 223 c
 224    21 continue
 225 c
 226       endif
 227 c
 228 #ifdef _DEBUG_HOMARD_
 229           if ( codret.eq.0 ) then
 230           call gmprsx (nompro, nocham(nrocha) )
 231           call gmprsx (nompro, nocham(nrocha)//'.Cham_Ent' )
 232           call gmprsx (nompro, nocham(nrocha)//'.Cham_Car' )
 233           endif
 234 #endif
 235 c
 236    20 continue
 237 c
 238 c====
 239 c 3. la fin
 240 c====
 241 c
 242       if ( codret.ne.0 ) then
 243 c
 244 #include "envex2.h"
 245 c
 246       write (ulsort,texte(langue,1)) 'Sortie', nompro
 247       write (ulsort,texte(langue,2)) codret
 248 c
 249       endif
 250 c
 251 #ifdef _DEBUG_HOMARD_
 252       write (ulsort,texte(langue,1)) 'Sortie', nompro
 253       call dmflsh (iaux)
 254 #endif
 255 c
 256       end