src/tool/AP_Conversion/pccafo.F

   1       subroutine pccafo ( nrfonc, nofonc, obprof, oblopg,
   2      >                    nbpara, carenf, carach,
   3      >                    option,
   4      >                    ulsort, langue, codret )
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c    aPres adaptation - mise a jour des CAracteristiques des FOnctions
  26 c     -                                 --                   --
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . nrfonc . e   .   1    . numero de la fonction a examiner           .
  32 c . nofonc .  s  . char8  . nom de la fonction iteration n+1           .
  33 c . obprof .  s  . char8  . nom de l'objet profil eventuel             .
  34 c . oblopg .  s  . char8  . nom de l'objet localisation points de Gauss.
  35 c . nbpara . e   .   1    . nombre de parametres a enregistrer par fonc.
  36 c . carenf .   s .nbpara* . caracteristiques entieres des fonctions :  .
  37 c .        .     .  nnfopa.  1 : 0, pour une fonction ancienne isolee  .
  38 c .        .     .        .      1, pour une ancienne associee a une   .
  39 c .        .     .        .         autre fonction                     .
  40 c .        .     .        .      -1, pour une nouvelle fonction        .
  41 c .        .     .        .  2 : typcha                                .
  42 c .        .     .        .  3 : typgeo                                .
  43 c .        .     .        .  4 : typass                                .
  44 c .        .     .        .  5 : ngauss                                .
  45 c .        .     .        .  6 : nnenmx                                .
  46 c .        .     .        .  7 : nnvapr                                .
  47 c .        .     .        .  8 : carsup                                .
  48 c .        .     .        .  9 : nbtafo                                .
  49 c .        .     .        . 10 : anvale                                .
  50 c .        .     .        . 11 : anvalr                                .
  51 c .        .     .        . 12 : anobch                                .
  52 c .        .     .        . 13 : anprpg                                .
  53 c .        .     .        . 14 : anlipr                                .
  54 c .        .     .        . 15 : npenmx                                .
  55 c .        .     .        . 16 : npvapr                                .
  56 c .        .     .        . 17 : apvale                                .
  57 c .        .     .        . 18 : apvalr                                .
  58 c .        .     .        . 19 : apobch                                .
  59 c .        .     .        . 20 : apprpg                                .
  60 c .        .     .        . 21 : apvatt                                .
  61 c .        .     .        . 22 : apvane                                .
  62 c .        .     .        . 23 : antyas                                .
  63 c .        .     .        . 24 : aptyas                                .
  64 c .        .     .        . 25 : numero de la 1ere fonction associee   .
  65 c .        .     .        . 26 : numero de la 2nde fonction associee   .
  66 c . carach . es  .nbpara* . caracteristiques caracteres des fonctions :.
  67 c .        .     .  nnfopa.  1 : nom de la fonction                    .
  68 c .        .     .        .  2 : nom de la fonction n associee         .
  69 c .        .     .        .  3 : nom de la fonction p associee         .
  70 c .        .     .        .  4 : obpcan                                .
  71 c .        .     .        .  5 : obpcap                                .
  72 c .        .     .        .  6 : obprof                                .
  73 c .        .     .        .  7 : oblopg                                .
  74 c .        .     .        .  8 : si aux points de Gauss, nom de la     .
  75 c .        .     .        .      fonction n ELNO correspondante        .
  76 c .        .     .        .  9 : si aux points de Gauss, nom de la     .
  77 c .        .     .        .      fonction p ELNO correspondante        .
  78 c . option . e   .    1   . option du traitement                       .
  79 c .        .     .        . -1 : Pas de changement dans le maillage    .
  80 c .        .     .        .  0 : Adaptation complete                   .
  81 c .        .     .        .  1 : Modification de degre                 .
  82 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  83 c . langue . e   .    1   . langue des messages                        .
  84 c .        .     .        . 1 : francais, 2 : anglais                  .
  85 c . codret . es  .    1   . code de retour des modules                 .
  86 c .        .     .        . 0 : pas de probleme                        .
  87 c .        .     .        . 1 : probleme                               .
  88 c ______________________________________________________________________
  89 c
  90 c====
  91 c 0. declarations et dimensionnement
  92 c====
  93 c
  94 c 0.1. ==> generalites
  95 c
  96       implicit none
  97       save
  98 c
  99       character*6 nompro
 100       parameter ( nompro = 'PCCAFO' )
 101 c
 102 #include "nblang.h"
 103 #include "consts.h"
 104 #include "meddc0.h"
 105 c
 106 c 0.2. ==> communs
 107 c
 108 #include "envex1.h"
 109 c
 110 #include "gmenti.h"
 111 #include "gmreel.h"
 112 #include "gmstri.h"
 113 c
 114 #include "nombsr.h"
 115 c
 116 c 0.3. ==> arguments
 117 c
 118       integer nrfonc
 119       integer nbpara
 120       integer carenf(nbpara,*)
 121       integer option
 122 c
 123       character*8 nofonc, obprof, oblopg
 124       character*8 carach(nbpara,*)
 125 c
 126       integer ulsort, langue, codret
 127 c
 128 c 0.4. ==> variables locales
 129 c
 130       integer iaux, jaux
 131       integer typfon, typcha, typgeo, typass
 132       integer ngauss, nnenmx, nnvapr, carsup, nbtafo
 133       integer n1vale, n1valr, n1prpg, n1obch, n1lipr
 134       integer npenmx, npvapr
 135       integer p1vale, p1valr, p1prpg, p1obch, p1vatt
 136       integer p1vane, p1tyas
 137       integer adpcan, adpcap
 138       integer nrfon2, nrfon3
 139       integer adinch
 140 c
 141       character*8 obpcan, obpcap
 142       character*8 obinch
 143 c
 144       integer nbmess
 145       parameter ( nbmess = 10 )
 146       character*80 texte(nblang,nbmess)
 147 c
 148 c 0.5. ==> initialisations
 149 c ______________________________________________________________________
 150 c
 151 c====
 152 c 1. initialisations
 153 c====
 154 c
 155 c 1.1. ==> messages
 156 c
 157 #include "impr01.h"
 158 #include "impr03.h"
 159 c
 160 #ifdef _DEBUG_HOMARD_
 161       write (ulsort,texte(langue,1)) 'Entree', nompro
 162       call dmflsh (iaux)
 163 #endif
 164 c
 165       texte(1,4) = '(''.. Fonction numero '',i6)'
 166       texte(1,5) = '(''Nom de la fonction = '',a8)'
 167 c
 168       texte(2,4) = '(''.. Function #'',i6)'
 169       texte(2,5) = '(''Name of the function ='',a8)'
 170 c
 171 #ifdef _DEBUG_HOMARD_
 172       write (ulsort,texte(langue,4)) nrfonc
 173       write (ulsort,90002) 'option', option
 174 #endif
 175 cgn      print *, nompro
 176 cgn      print 1788,(carenf(iaux,nrfonc),iaux=1,nbpara)
 177 cgn 1788  format(5I8)
 178 cgn      print 1789,(carach(iaux,nrfonc),iaux=1,nbpara)
 179 cgn 1789  format(5(a8,1x))
 180 c
 181 c====
 182 c 2. caracteristiques de la fonction
 183 c====
 184 c
 185 #ifdef _DEBUG_HOMARD_
 186       write (ulsort,texte(langue,3)) 'PCFOR2', nompro
 187 #endif
 188       iaux = nrfonc
 189       call pcfor2 ( nbpara, carenf, carach,
 190      >              iaux,
 191      >              typfon, typcha, typgeo, typass,
 192      >              ngauss, nnenmx, nnvapr, carsup, nbtafo,
 193      >              n1vale, n1valr, n1prpg, n1obch, n1lipr,
 194      >              npenmx, npvapr,
 195      >              p1vale, p1valr, p1prpg, p1obch, p1vatt,
 196      >              p1vane, p1tyas,
 197      >              nrfon2, nrfon3,
 198      >              nofonc,
 199      >              obpcan, obpcap, obprof, adpcan, adpcap,
 200      >              oblopg,
 201      >              ulsort, langue, codret )
 202 c
 203 #ifdef _DEBUG_HOMARD_
 204       write (ulsort,texte(langue,5)) nofonc
 205 #endif
 206 c
 207 c====
 208 c 3. mise a jour des informations
 209 c====
 210 c
 211 c 3.1. ==> nombre de valeurs du profil
 212 c
 213       if ( codret.eq.0 ) then
 214 c
 215       call gmecat ( nofonc, 4, npvapr, codret )
 216 c
 217       endif
 218 c
 219 c 3.2. ==> les noms
 220 c
 221       if ( codret.eq.0 ) then
 222 c
 223       smem(p1prpg  ) = obprof
 224       smem(p1prpg+1) = oblopg
 225 c
 226       endif
 227 c
 228 c 3.3. ==> changement de degre
 229 c
 230       if ( option.eq.1 ) then
 231 c
 232 c 3.3.1. ==> le champ associe a la fonction
 233 c            remarque : on aurait pu modifier utmoch
 234 c
 235       do 332 , iaux =  1 , nbtafo
 236 c
 237         if ( codret.eq.0 ) then
 238 c
 239         obinch = smem(n1obch-1+iaux)
 240         call gmadoj ( obinch//'.Cham_Ent', adinch, jaux, codret )
 241 c
 242         endif
 243 c
 244         if ( codret.eq.0 ) then
 245 c
 246         imem(adinch  ) = carenf(3,nrfonc)
 247         imem(adinch+3) = carenf(5,nrfonc)
 248 c
 249         endif
 250 c
 251   332 continue
 252 c
 253       endif
 254 c
 255 c====
 256 c 4. compactage des valeurs pour les fonctions sur les elements
 257 c    remarque : le traitement sur les fonctions aux noeuds est
 258 c               different. Il est fait directement dans pcsono.
 259 c====
 260 c
 261       if ( codret.eq.0 ) then
 262 cgn      print *,nompro
 263 cgn      print *,'p1vatt = ',p1vatt
 264 cgn      print *,'rmem(p1vatt+13) = ',rmem(p1vatt+13)
 265 c
 266       if ( typgeo.ne.0 ) then
 267 c
 268         if  ( ngauss.eq.ednopg ) then
 269 c
 270 #ifdef _DEBUG_HOMARD_
 271       write (ulsort,texte(langue,3)) 'UTSRC1', nompro
 272 #endif
 273           call utsrc1 ( nbtafo, rseutc,
 274      >                  imem(adpcap), rmem(p1vatt), rmem(p1valr) )
 275 c
 276         else
 277 c
 278 #ifdef _DEBUG_HOMARD_
 279       write (ulsort,texte(langue,3)) 'UTSRC2', nompro
 280 #endif
 281           call utsrc2 ( nbtafo, ngauss, rseutc,
 282      >                  imem(adpcap), rmem(p1vatt), rmem(p1valr) )
 283 c
 284         endif
 285 c
 286 cgn      print *,nompro,' ==> codret = ',codret
 287 cgn      print 1790,(rmem(p1valr+iaux-1),iaux=1,nbtafo*rsevca)
 288 cgn 1790 format(10g13.5)
 289 c
 290       endif
 291 c
 292       endif
 293 c
 294 #ifdef _DEBUG_HOMARD_
 295       call gmprsx (nompro,nofonc)
 296       call gmprsx (nompro,nofonc//'.ValeursR')
 297       call gmprsx (nompro,nofonc//'.InfoPrPG')
 298       if ( npvapr.gt.0 ) then
 299         call gmprsx (nompro,obprof)
 300       endif
 301       if ( oblopg.ne.blan08 ) then
 302         call gmprsx (nompro,oblopg)
 303       endif
 304 #endif
 305 c
 306 c====
 307 c 5. la fin
 308 c====
 309 c
 310       if ( codret.ne.0 ) then
 311 c
 312 #include "envex2.h"
 313 c
 314       write (ulsort,texte(langue,1)) 'Sortie', nompro
 315       write (ulsort,texte(langue,2)) codret
 316 c
 317       endif
 318 c
 319 #ifdef _DEBUG_HOMARD_
 320       write (ulsort,texte(langue,1)) 'Sortie', nompro
 321       call dmflsh (iaux)
 322 #endif
 323 c
 324       end